Theory General
section ‹General Utilities› theory General imports Polynomials.Utils begin text ‹A couple of general-purpose functions and lemmas, mainly related to lists.› subsection ‹Lists› lemma distinct_reorder: "distinct (xs @ (y # ys)) = distinct (y # (xs @ ys))" by auto lemma set_reorder: "set (xs @ (y # ys)) = set (y # (xs @ ys))" by simp lemma distinctI: assumes "⋀i j. i < j ⟹ i < length xs ⟹ j < length xs ⟹ xs ! i ≠ xs ! j" shows "distinct xs" using assms proof (induct xs) case Nil show ?case by simp next case (Cons x xs) show ?case proof (simp, intro conjI, rule) assume "x ∈ set xs" then obtain j where "j < length xs" and "x = xs ! j" by (metis in_set_conv_nth) hence "Suc j < length (x # xs)" by simp have "(x # xs) ! 0 ≠ (x # xs) ! (Suc j)" by (rule Cons(2), simp, simp, fact) thus False by (simp add: ‹x = xs ! j›) next show "distinct xs" proof (rule Cons(1)) fix i j assume "i < j" and "i < length xs" and "j < length xs" hence "Suc i < Suc j" and "Suc i < length (x # xs)" and "Suc j < length (x # xs)" by simp_all hence "(x # xs) ! (Suc i) ≠ (x # xs) ! (Suc j)" by (rule Cons(2)) thus "xs ! i ≠ xs ! j" by simp qed qed qed lemma filter_nth_pairE: assumes "i < j" and "i < length (filter P xs)" and "j < length (filter P xs)" obtains i' j' where "i' < j'" and "i' < length xs" and "j' < length xs" and "(filter P xs) ! i = xs ! i'" and "(filter P xs) ! j = xs ! j'" using assms proof (induct xs arbitrary: i j thesis) case Nil from Nil(3) show ?case by simp next case (Cons x xs) let ?ys = "filter P (x # xs)" show ?case proof (cases "P x") case True hence *: "?ys = x # (filter P xs)" by simp from ‹i < j› obtain j0 where j: "j = Suc j0" using lessE by blast have len_ys: "length ?ys = Suc (length (filter P xs))" and ys_j: "?ys ! j = (filter P xs) ! j0" by (simp only: * length_Cons, simp only: j * nth_Cons_Suc) from Cons(5) have "j0 < length (filter P xs)" unfolding len_ys j by auto show ?thesis proof (cases "i = 0") case True from ‹j0 < length (filter P xs)› obtain j' where "j' < length xs" and **: "(filter P xs) ! j0 = xs ! j'" by (metis (no_types, lifting) in_set_conv_nth mem_Collect_eq nth_mem set_filter) have "0 < Suc j'" by simp thus ?thesis by (rule Cons(2), simp, simp add: ‹j' < length xs›, simp only: True * nth_Cons_0, simp only: ys_j nth_Cons_Suc **) next case False then obtain i0 where i: "i = Suc i0" using lessE by blast have ys_i: "?ys ! i = (filter P xs) ! i0" by (simp only: i * nth_Cons_Suc) from Cons(3) have "i0 < j0" by (simp add: i j) from Cons(4) have "i0 < length (filter P xs)" unfolding len_ys i by auto from _ ‹i0 < j0› this ‹j0 < length (filter P xs)› obtain i' j' where "i' < j'" and "i' < length xs" and "j' < length xs" and i': "filter P xs ! i0 = xs ! i'" and j': "filter P xs ! j0 = xs ! j'" by (rule Cons(1)) from ‹i' < j'› have "Suc i' < Suc j'" by simp thus ?thesis by (rule Cons(2), simp add: ‹i' < length xs›, simp add: ‹j' < length xs›, simp only: ys_i nth_Cons_Suc i', simp only: ys_j nth_Cons_Suc j') qed next case False hence *: "?ys = filter P xs" by simp with Cons(4) Cons(5) have "i < length (filter P xs)" and "j < length (filter P xs)" by simp_all with _ ‹i < j› obtain i' j' where "i' < j'" and "i' < length xs" and "j' < length xs" and i': "filter P xs ! i = xs ! i'" and j': "filter P xs ! j = xs ! j'" by (rule Cons(1)) from ‹i' < j'› have "Suc i' < Suc j'" by simp thus ?thesis by (rule Cons(2), simp add: ‹i' < length xs›, simp add: ‹j' < length xs›, simp only: * nth_Cons_Suc i', simp only: * nth_Cons_Suc j') qed qed lemma distinct_filterI: assumes "⋀i j. i < j ⟹ i < length xs ⟹ j < length xs ⟹ P (xs ! i) ⟹ P (xs ! j) ⟹ xs ! i ≠ xs ! j" shows "distinct (filter P xs)" proof (rule distinctI) fix i j::nat assume "i < j" and "i < length (filter P xs)" and "j < length (filter P xs)" then obtain i' j' where "i' < j'" and "i' < length xs" and "j' < length xs" and i: "(filter P xs) ! i = xs ! i'" and j: "(filter P xs) ! j = xs ! j'" by (rule filter_nth_pairE) from ‹i' < j'› ‹i' < length xs› ‹j' < length xs› show "(filter P xs) ! i ≠ (filter P xs) ! j" unfolding i j proof (rule assms) from ‹i < length (filter P xs)› show "P (xs ! i')" unfolding i[symmetric] using nth_mem by force next from ‹j < length (filter P xs)› show "P (xs ! j')" unfolding j[symmetric] using nth_mem by force qed qed lemma set_zip_map: "set (zip (map f xs) (map g xs)) = (λx. (f x, g x)) ` (set xs)" proof - have "{(map f xs ! i, map g xs ! i) |i. i < length xs} = {(f (xs ! i), g (xs ! i)) |i. i < length xs}" proof (rule Collect_eqI, rule, elim exE conjE, intro exI conjI, simp add: map_nth, assumption, elim exE conjE, intro exI) fix x i assume "x = (f (xs ! i), g (xs ! i))" and "i < length xs" thus "x = (map f xs ! i, map g xs ! i) ∧ i < length xs" by (simp add: map_nth) qed also have "... = (λx. (f x, g x)) ` {xs ! i | i. i < length xs}" by blast finally show "set (zip (map f xs) (map g xs)) = (λx. (f x, g x)) ` (set xs)" by (simp add: set_zip set_conv_nth[symmetric]) qed lemma set_zip_map1: "set (zip (map f xs) xs) = (λx. (f x, x)) ` (set xs)" proof - have "set (zip (map f xs) (map id xs)) = (λx. (f x, id x)) ` (set xs)" by (rule set_zip_map) thus ?thesis by simp qed lemma set_zip_map2: "set (zip xs (map f xs)) = (λx. (x, f x)) ` (set xs)" proof - have "set (zip (map id xs) (map f xs)) = (λx. (id x, f x)) ` (set xs)" by (rule set_zip_map) thus ?thesis by simp qed lemma UN_upt: "(⋃i∈{0..<length xs}. f (xs ! i)) = (⋃x∈set xs. f x)" by (metis image_image map_nth set_map set_upt) lemma sum_list_zeroI': assumes "⋀i. i < length xs ⟹ xs ! i = 0" shows "sum_list xs = 0" proof (rule sum_list_zeroI, rule, simp) fix x assume "x ∈ set xs" then obtain i where "i < length xs" and "x = xs ! i" by (metis in_set_conv_nth) from this(1) show "x = 0" unfolding ‹x = xs ! i› by (rule assms) qed lemma sum_list_map2_plus: assumes "length xs = length ys" shows "sum_list (map2 (+) xs ys) = sum_list xs + sum_list (ys::'a::comm_monoid_add list)" using assms proof (induct rule: list_induct2) case Nil show ?case by simp next case (Cons x xs y ys) show ?case by (simp add: Cons(2) ac_simps) qed lemma sum_list_eq_nthI: assumes "i < length xs" and "⋀j. j < length xs ⟹ j ≠ i ⟹ xs ! j = 0" shows "sum_list xs = xs ! i" using assms proof (induct xs arbitrary: i) case Nil from Nil(1) show ?case by simp next case (Cons x xs) have *: "xs ! j = 0" if "j < length xs" and "Suc j ≠ i" for j proof - have "xs ! j = (x # xs) ! (Suc j)" by simp also have "... = 0" by (rule Cons(3), simp add: ‹j < length xs›, fact) finally show ?thesis . qed show ?case proof (cases i) case 0 have "sum_list xs = 0" by (rule sum_list_zeroI', erule *, simp add: 0) with 0 show ?thesis by simp next case (Suc k) with Cons(2) have "k < length xs" by simp hence "sum_list xs = xs ! k" proof (rule Cons(1)) fix j assume "j < length xs" assume "j ≠ k" hence "Suc j ≠ i" by (simp add: Suc) with ‹j < length xs› show "xs ! j = 0" by (rule *) qed moreover have "x = 0" proof - have "x = (x # xs) ! 0" by simp also have "... = 0" by (rule Cons(3), simp_all add: Suc) finally show ?thesis . qed ultimately show ?thesis by (simp add: Suc) qed qed subsubsection ‹‹max_list›› fun (in ord) max_list :: "'a list ⇒ 'a" where "max_list (x # xs) = (case xs of [] ⇒ x | _ ⇒ max x (max_list xs))" context linorder begin lemma max_list_Max: "xs ≠ [] ⟹ max_list xs = Max (set xs)" by (induct xs rule: induct_list012, auto) lemma max_list_ge: assumes "x ∈ set xs" shows "x ≤ max_list xs" proof - from assms have "xs ≠ []" by auto from finite_set assms have "x ≤ Max (set xs)" by (rule Max_ge) also from ‹xs ≠ []› have "Max (set xs) = max_list xs" by (rule max_list_Max[symmetric]) finally show ?thesis . qed lemma max_list_boundedI: assumes "xs ≠ []" and "⋀x. x ∈ set xs ⟹ x ≤ a" shows "max_list xs ≤ a" proof - from assms(1) have "set xs ≠ {}" by simp from assms(1) have "max_list xs = Max (set xs)" by (rule max_list_Max) also from finite_set ‹set xs ≠ {}› assms(2) have "… ≤ a" by (rule Max.boundedI) finally show ?thesis . qed end subsubsection ‹‹insort_wrt›› primrec insort_wrt :: "('c ⇒ 'c ⇒ bool) ⇒ 'c ⇒ 'c list ⇒ 'c list" where "insort_wrt _ x [] = [x]" | "insort_wrt r x (y # ys) = (if r x y then (x # y # ys) else y # (insort_wrt r x ys))" lemma insort_wrt_not_Nil [simp]: "insort_wrt r x xs ≠ []" by (induct xs, simp_all) lemma length_insort_wrt [simp]: "length (insort_wrt r x xs) = Suc (length xs)" by (induct xs, simp_all) lemma set_insort_wrt [simp]: "set (insort_wrt r x xs) = insert x (set xs)" by (induct xs, auto) lemma sorted_wrt_insort_wrt_imp_sorted_wrt: assumes "sorted_wrt r (insort_wrt s x xs)" shows "sorted_wrt r xs" using assms proof (induct xs) case Nil show ?case by simp next case (Cons a xs) show ?case proof (cases "s x a") case True with Cons.prems have "sorted_wrt r (x # a # xs)" by simp thus ?thesis by simp next case False with Cons(2) have "sorted_wrt r (a # (insort_wrt s x xs))" by simp hence *: "(∀y∈set xs. r a y)" and "sorted_wrt r (insort_wrt s x xs)" by (simp_all) from this(2) have "sorted_wrt r xs" by (rule Cons(1)) with * show ?thesis by (simp) qed qed lemma sorted_wrt_imp_sorted_wrt_insort_wrt: assumes "transp r" and "⋀a. r a x ∨ r x a" and "sorted_wrt r xs" shows "sorted_wrt r (insort_wrt r x xs)" using assms(3) proof (induct xs) case Nil show ?case by simp next case (Cons a xs) show ?case proof (cases "r x a") case True with Cons(2) assms(1) show ?thesis by (auto dest: transpD) next case False with assms(2) have "r a x" by blast from Cons(2) have *: "(∀y∈set xs. r a y)" and "sorted_wrt r xs" by (simp_all) from this(2) have "sorted_wrt r (insort_wrt r x xs)" by (rule Cons(1)) with ‹r a x› * show ?thesis by (simp add: False) qed qed corollary sorted_wrt_insort_wrt: assumes "transp r" and "⋀a. r a x ∨ r x a" shows "sorted_wrt r (insort_wrt r x xs) ⟷ sorted_wrt r xs" (is "?l ⟷ ?r") proof assume ?l then show ?r by (rule sorted_wrt_insort_wrt_imp_sorted_wrt) next assume ?r with assms show ?l by (rule sorted_wrt_imp_sorted_wrt_insort_wrt) qed subsubsection ‹‹diff_list› and ‹insert_list›› definition diff_list :: "'a list ⇒ 'a list ⇒ 'a list" (infixl "--" 65) where "diff_list xs ys = fold removeAll ys xs" lemma set_diff_list: "set (xs -- ys) = set xs - set ys" by (simp only: diff_list_def, induct ys arbitrary: xs, auto) lemma diff_list_disjoint: "set ys ∩ set (xs -- ys) = {}" unfolding set_diff_list by (rule Diff_disjoint) lemma subset_append_diff_cancel: assumes "set ys ⊆ set xs" shows "set (ys @ (xs -- ys)) = set xs" by (simp only: set_append set_diff_list Un_Diff_cancel, rule Un_absorb1, fact) definition insert_list :: "'a ⇒ 'a list ⇒ 'a list" where "insert_list x xs = (if x ∈ set xs then xs else x # xs)" lemma set_insert_list: "set (insert_list x xs) = insert x (set xs)" by (auto simp add: insert_list_def) subsubsection ‹‹remdups_wrt›› primrec remdups_wrt :: "('a ⇒ 'b) ⇒ 'a list ⇒ 'a list" where remdups_wrt_base: "remdups_wrt _ [] = []" | remdups_wrt_rec: "remdups_wrt f (x # xs) = (if f x ∈ f ` set xs then remdups_wrt f xs else x # remdups_wrt f xs)" lemma set_remdups_wrt: "f ` set (remdups_wrt f xs) = f ` set xs" proof (induct xs) case Nil show ?case unfolding remdups_wrt_base .. next case (Cons a xs) show ?case unfolding remdups_wrt_rec proof (simp only: split: if_splits, intro conjI, intro impI) assume "f a ∈ f ` set xs" have "f ` set (a # xs) = insert (f a) (f ` set xs)" by simp have "f ` set (remdups_wrt f xs) = f ` set xs" by fact also from ‹f a ∈ f ` set xs› have "... = insert (f a) (f ` set xs)" by (simp add: insert_absorb) also have "... = f ` set (a # xs)" by simp finally show "f ` set (remdups_wrt f xs) = f ` set (a # xs)" . qed (simp add: Cons.hyps) qed lemma subset_remdups_wrt: "set (remdups_wrt f xs) ⊆ set xs" by (induct xs, auto) lemma remdups_wrt_distinct_wrt: assumes "x ∈ set (remdups_wrt f xs)" and "y ∈ set (remdups_wrt f xs)" and "x ≠ y" shows "f x ≠ f y" using assms(1) assms(2) proof (induct xs) case Nil thus ?case unfolding remdups_wrt_base by simp next case (Cons a xs) from Cons(2) Cons(3) show ?case unfolding remdups_wrt_rec proof (simp only: split: if_splits) assume "x ∈ set (remdups_wrt f xs)" and "y ∈ set (remdups_wrt f xs)" thus "f x ≠ f y" by (rule Cons.hyps) next assume "¬ True" thus "f x ≠ f y" by simp next assume "f a ∉ f ` set xs" and xin: "x ∈ set (a # remdups_wrt f xs)" and yin: "y ∈ set (a # remdups_wrt f xs)" from yin have y: "y = a ∨ y ∈ set (remdups_wrt f xs)" by simp from xin have "x = a ∨ x ∈ set (remdups_wrt f xs)" by simp thus "f x ≠ f y" proof assume "x = a" from y show ?thesis proof assume "y = a" with ‹x ≠ y› show ?thesis unfolding ‹x = a› by simp next assume "y ∈ set (remdups_wrt f xs)" have "y ∈ set xs" by (rule, fact, rule subset_remdups_wrt) hence "f y ∈ f ` set xs" by simp with ‹f a ∉ f ` set xs› show ?thesis unfolding ‹x = a› by auto qed next assume "x ∈ set (remdups_wrt f xs)" from y show ?thesis proof assume "y = a" have "x ∈ set xs" by (rule, fact, rule subset_remdups_wrt) hence "f x ∈ f ` set xs" by simp with ‹f a ∉ f ` set xs› show ?thesis unfolding ‹y = a› by auto next assume "y ∈ set (remdups_wrt f xs)" with ‹x ∈ set (remdups_wrt f xs)› show ?thesis by (rule Cons.hyps) qed qed qed qed lemma distinct_remdups_wrt: "distinct (remdups_wrt f xs)" proof (induct xs) case Nil show ?case unfolding remdups_wrt_base by simp next case (Cons a xs) show ?case unfolding remdups_wrt_rec proof (split if_split, intro conjI impI, rule Cons.hyps) assume "f a ∉ f ` set xs" hence "a ∉ set xs" by auto hence "a ∉ set (remdups_wrt f xs)" using subset_remdups_wrt[of f xs] by auto with Cons.hyps show "distinct (a # remdups_wrt f xs)" by simp qed qed lemma map_remdups_wrt: "map f (remdups_wrt f xs) = remdups (map f xs)" by (induct xs, auto) lemma remdups_wrt_append: "remdups_wrt f (xs @ ys) = (filter (λa. f a ∉ f ` set ys) (remdups_wrt f xs)) @ (remdups_wrt f ys)" by (induct xs, auto) subsubsection ‹‹map_idx›› primrec map_idx :: "('a ⇒ nat ⇒ 'b) ⇒ 'a list ⇒ nat ⇒ 'b list" where "map_idx f [] n = []"| "map_idx f (x # xs) n = (f x n) # (map_idx f xs (Suc n))" lemma map_idx_eq_map2: "map_idx f xs n = map2 f xs [n..<n + length xs]" proof (induct xs arbitrary: n) case Nil show ?case by simp next case (Cons x xs) have eq: "[n..<n + length (x # xs)] = n # [Suc n..<Suc (n + length xs)]" by (metis add_Suc_right length_Cons less_add_Suc1 upt_conv_Cons) show ?case unfolding eq by (simp add: Cons del: upt_Suc) qed lemma length_map_idx [simp]: "length (map_idx f xs n) = length xs" by (simp add: map_idx_eq_map2) lemma map_idx_append: "map_idx f (xs @ ys) n = (map_idx f xs n) @ (map_idx f ys (n + length xs))" by (simp add: map_idx_eq_map2 ab_semigroup_add_class.add_ac(1) zip_append1) lemma map_idx_nth: assumes "i < length xs" shows "(map_idx f xs n) ! i = f (xs ! i) (n + i)" using assms by (simp add: map_idx_eq_map2) lemma map_map_idx: "map f (map_idx g xs n) = map_idx (λx i. f (g x i)) xs n" by (auto simp add: map_idx_eq_map2) lemma map_idx_map: "map_idx f (map g xs) n = map_idx (f ∘ g) xs n" by (simp add: map_idx_eq_map2 map_zip_map) lemma map_idx_no_idx: "map_idx (λx _. f x) xs n = map f xs" by (induct xs arbitrary: n, simp_all) lemma map_idx_no_elem: "map_idx (λ_. f) xs n = map f [n..<n + length xs]" proof (induct xs arbitrary: n) case Nil show ?case by simp next case (Cons x xs) have eq: "[n..<n + length (x # xs)] = n # [Suc n..<Suc (n + length xs)]" by (metis add_Suc_right length_Cons less_add_Suc1 upt_conv_Cons) show ?case unfolding eq by (simp add: Cons del: upt_Suc) qed lemma map_idx_eq_map: "map_idx f xs n = map (λi. f (xs ! i) (i + n)) [0..<length xs]" proof (induct xs arbitrary: n) case Nil show ?case by simp next case (Cons x xs) have eq: "[0..<length (x # xs)] = 0 # [Suc 0..<Suc (length xs)]" by (metis length_Cons upt_conv_Cons zero_less_Suc) have "map (λi. f ((x # xs) ! i) (i + n)) [Suc 0..<Suc (length xs)] = map ((λi. f ((x # xs) ! i) (i + n)) ∘ Suc) [0..<length xs]" by (metis map_Suc_upt map_map) also have "... = map (λi. f (xs ! i) (Suc (i + n))) [0..<length xs]" by (rule map_cong, fact refl, simp) finally show ?case unfolding eq by (simp add: Cons del: upt_Suc) qed lemma set_map_idx: "set (map_idx f xs n) = (λi. f (xs ! i) (i + n)) ` {0..<length xs}" by (simp add: map_idx_eq_map) subsubsection ‹‹map_dup›› primrec map_dup :: "('a ⇒ 'b) ⇒ ('a ⇒ 'b) ⇒ 'a list ⇒ 'b list" where "map_dup _ _ [] = []"| "map_dup f g (x # xs) = (if x ∈ set xs then g x else f x) # (map_dup f g xs)" lemma length_map_dup[simp]: "length (map_dup f g xs) = length xs" by (induct xs, simp_all) lemma map_dup_distinct: assumes "distinct xs" shows "map_dup f g xs = map f xs" using assms by (induct xs, simp_all) lemma filter_map_dup_const: "filter (λx. x ≠ c) (map_dup f (λ_. c) xs) = filter (λx. x ≠ c) (map f (remdups xs))" by (induct xs, simp_all) lemma filter_zip_map_dup_const: "filter (λ(a, b). a ≠ c) (zip (map_dup f (λ_. c) xs) xs) = filter (λ(a, b). a ≠ c) (zip (map f (remdups xs)) (remdups xs))" by (induct xs, simp_all) subsubsection ‹Filtering Minimal Elements› context fixes rel :: "'a ⇒ 'a ⇒ bool" begin primrec filter_min_aux :: "'a list ⇒ 'a list ⇒ 'a list" where "filter_min_aux [] ys = ys"| "filter_min_aux (x # xs) ys = (if (∃y∈(set xs ∪ set ys). rel y x) then (filter_min_aux xs ys) else (filter_min_aux xs (x # ys)))" definition filter_min :: "'a list ⇒ 'a list" where "filter_min xs = filter_min_aux xs []" definition filter_min_append :: "'a list ⇒ 'a list ⇒ 'a list" where "filter_min_append xs ys = (let P = (λzs. λx. ¬ (∃z∈set zs. rel z x)); ys1 = filter (P xs) ys in (filter (P ys1) xs) @ ys1)" lemma filter_min_aux_supset: "set ys ⊆ set (filter_min_aux xs ys)" proof (induct xs arbitrary: ys) case Nil show ?case by simp next case (Cons x xs) have "set ys ⊆ set (x # ys)" by auto also have "set (x # ys) ⊆ set (filter_min_aux xs (x # ys))" by (rule Cons.hyps) finally have "set ys ⊆ set (filter_min_aux xs (x # ys))" . moreover have "set ys ⊆ set (filter_min_aux xs ys)" by (rule Cons.hyps) ultimately show ?case by simp qed lemma filter_min_aux_subset: "set (filter_min_aux xs ys) ⊆ set xs ∪ set ys" proof (induct xs arbitrary: ys) case Nil show ?case by simp next case (Cons x xs) note Cons.hyps also have "set xs ∪ set ys ⊆ set (x # xs) ∪ set ys" by fastforce finally have c1: "set (filter_min_aux xs ys) ⊆ set (x # xs) ∪ set ys" . note Cons.hyps also have "set xs ∪ set (x # ys) = set (x # xs) ∪ set ys" by simp finally have "set (filter_min_aux xs (x # ys)) ⊆ set (x # xs) ∪ set ys" . with c1 show ?case by simp qed lemma filter_min_aux_relE: assumes "transp rel" and "x ∈ set xs" and "x ∉ set (filter_min_aux xs ys)" obtains y where "y ∈ set (filter_min_aux xs ys)" and "rel y x" using assms(2, 3) proof (induct xs arbitrary: x ys thesis) case Nil from Nil(2) show ?case by simp next case (Cons x0 xs) from Cons(3) have "x = x0 ∨ x ∈ set xs" by simp thus ?case proof assume "x = x0" from Cons(4) have *: "∃y∈set xs ∪ set ys. rel y x0" proof (simp add: ‹x = x0› split: if_splits) assume "x0 ∉ set (filter_min_aux xs (x0 # ys))" moreover from filter_min_aux_supset have "x0 ∈ set (filter_min_aux xs (x0 # ys))" by (rule subsetD) simp ultimately show False .. qed hence eq: "filter_min_aux (x0 # xs) ys = filter_min_aux xs ys" by simp from * obtain x1 where "x1 ∈ set xs ∪ set ys" and "rel x1 x" unfolding ‹x = x0› .. from this(1) show ?thesis proof assume "x1 ∈ set xs" show ?thesis proof (cases "x1 ∈ set (filter_min_aux xs ys)") case True hence "x1 ∈ set (filter_min_aux (x0 # xs) ys)" by (simp only: eq) thus ?thesis using ‹rel x1 x› by (rule Cons(2)) next case False with ‹x1 ∈ set xs› obtain y where "y ∈ set (filter_min_aux xs ys)" and "rel y x1" using Cons.hyps by blast from this(1) have "y ∈ set (filter_min_aux (x0 # xs) ys)" by (simp only: eq) moreover from assms(1) ‹rel y x1› ‹rel x1 x› have "rel y x" by (rule transpD) ultimately show ?thesis by (rule Cons(2)) qed next assume "x1 ∈ set ys" hence "x1 ∈ set (filter_min_aux (x0 # xs) ys)" using filter_min_aux_supset .. thus ?thesis using ‹rel x1 x› by (rule Cons(2)) qed next assume "x ∈ set xs" show ?thesis proof (cases "∃y∈set xs ∪ set ys. rel y x0") case True hence eq: "filter_min_aux (x0 # xs) ys = filter_min_aux xs ys" by simp with Cons(4) have "x ∉ set (filter_min_aux xs ys)" by simp with ‹x ∈ set xs› obtain y where "y ∈ set (filter_min_aux xs ys)" and "rel y x" using Cons.hyps by blast from this(1) have "y ∈ set (filter_min_aux (x0 # xs) ys)" by (simp only: eq) thus ?thesis using ‹rel y x› by (rule Cons(2)) next case False hence eq: "filter_min_aux (x0 # xs) ys = filter_min_aux xs (x0 # ys)" by simp with Cons(4) have "x ∉ set (filter_min_aux xs (x0 # ys))" by simp with ‹x ∈ set xs› obtain y where "y ∈ set (filter_min_aux xs (x0 # ys))" and "rel y x" using Cons.hyps by blast from this(1) have "y ∈ set (filter_min_aux (x0 # xs) ys)" by (simp only: eq) thus ?thesis using ‹rel y x› by (rule Cons(2)) qed qed qed lemma filter_min_aux_minimal: assumes "transp rel" and "x ∈ set (filter_min_aux xs ys)" and "y ∈ set (filter_min_aux xs ys)" and "rel x y" assumes "⋀a b. a ∈ set xs ∪ set ys ⟹ b ∈ set ys ⟹ rel a b ⟹ a = b" shows "x = y" using assms(2-5) proof (induct xs arbitrary: x y ys) case Nil from Nil(1) have "x ∈ set [] ∪ set ys" by simp moreover from Nil(2) have "y ∈ set ys" by simp ultimately show ?case using Nil(3) by (rule Nil(4)) next case (Cons x0 xs) show ?case proof (cases "∃y∈set xs ∪ set ys. rel y x0") case True hence eq: "filter_min_aux (x0 # xs) ys = filter_min_aux xs ys" by simp with Cons(2, 3) have "x ∈ set (filter_min_aux xs ys)" and "y ∈ set (filter_min_aux xs ys)" by simp_all thus ?thesis using Cons(4) proof (rule Cons.hyps) fix a b assume "a ∈ set xs ∪ set ys" hence "a ∈ set (x0 # xs) ∪ set ys" by simp moreover assume "b ∈ set ys" and "rel a b" ultimately show "a = b" by (rule Cons(5)) qed next case False hence eq: "filter_min_aux (x0 # xs) ys = filter_min_aux xs (x0 # ys)" by simp with Cons(2, 3) have "x ∈ set (filter_min_aux xs (x0 # ys))" and "y ∈ set (filter_min_aux xs (x0 # ys))" by simp_all thus ?thesis using Cons(4) proof (rule Cons.hyps) fix a b assume a: "a ∈ set xs ∪ set (x0 # ys)" and "b ∈ set (x0 # ys)" and "rel a b" from this(2) have "b = x0 ∨ b ∈ set ys" by simp thus "a = b" proof assume "b = x0" from a have "a = x0 ∨ a ∈ set xs ∪ set ys" by simp thus ?thesis proof assume "a = x0" with ‹b = x0› show ?thesis by simp next assume "a ∈ set xs ∪ set ys" hence "∃y∈set xs ∪ set ys. rel y x0" using ‹rel a b› unfolding ‹b = x0› .. with False show ?thesis .. qed next from a have "a ∈ set (x0 # xs) ∪ set ys" by simp moreover assume "b ∈ set ys" ultimately show ?thesis using ‹rel a b› by (rule Cons(5)) qed qed qed qed lemma filter_min_aux_distinct: assumes "reflp rel" and "distinct ys" shows "distinct (filter_min_aux xs ys)" using assms(2) proof (induct xs arbitrary: ys) case Nil thus ?case by simp next case (Cons x xs) show ?case proof (simp split: if_split, intro conjI impI) from Cons(2) show "distinct (filter_min_aux xs ys)" by (rule Cons.hyps) next assume a: "∀y∈set xs ∪ set ys. ¬ rel y x" show "distinct (filter_min_aux xs (x # ys))" proof (rule Cons.hyps) have "x ∉ set ys" proof assume "x ∈ set ys" hence "x ∈ set xs ∪ set ys" by simp with a have "¬ rel x x" .. moreover from assms(1) have "rel x x" by (rule reflpD) ultimately show False .. qed with Cons(2) show "distinct (x # ys)" by simp qed qed qed lemma filter_min_subset: "set (filter_min xs) ⊆ set xs" using filter_min_aux_subset[of xs "[]"] by (simp add: filter_min_def) lemma filter_min_cases: assumes "transp rel" and "x ∈ set xs" assumes "x ∈ set (filter_min xs) ⟹ thesis" assumes "⋀y. y ∈ set (filter_min xs) ⟹ x ∉ set (filter_min xs) ⟹ rel y x ⟹ thesis" shows thesis proof (cases "x ∈ set (filter_min xs)") case True thus ?thesis by (rule assms(3)) next case False with assms(1, 2) obtain y where "y ∈ set (filter_min xs)" and "rel y x" unfolding filter_min_def by (rule filter_min_aux_relE) from this(1) False this(2) show ?thesis by (rule assms(4)) qed corollary filter_min_relE: assumes "transp rel" and "reflp rel" and "x ∈ set xs" obtains y where "y ∈ set (filter_min xs)" and "rel y x" using assms(1, 3) proof (rule filter_min_cases) assume "x ∈ set (filter_min xs)" moreover from assms(2) have "rel x x" by (rule reflpD) ultimately show ?thesis .. qed lemma filter_min_minimal: assumes "transp rel" and "x ∈ set (filter_min xs)" and "y ∈ set (filter_min xs)" and "rel x y" shows "x = y" using assms unfolding filter_min_def by (rule filter_min_aux_minimal) simp lemma filter_min_distinct: assumes "reflp rel" shows "distinct (filter_min xs)" unfolding filter_min_def by (rule filter_min_aux_distinct, fact, simp) lemma filter_min_append_subset: "set (filter_min_append xs ys) ⊆ set xs ∪ set ys" by (auto simp: filter_min_append_def) lemma filter_min_append_cases: assumes "transp rel" and "x ∈ set xs ∪ set ys" assumes "x ∈ set (filter_min_append xs ys) ⟹ thesis" assumes "⋀y. y ∈ set (filter_min_append xs ys) ⟹ x ∉ set (filter_min_append xs ys) ⟹ rel y x ⟹ thesis" shows thesis proof (cases "x ∈ set (filter_min_append xs ys)") case True thus ?thesis by (rule assms(3)) next case False define P where "P = (λzs. λa. ¬ (∃z∈set zs. rel z a))" from assms(2) obtain y where "y ∈ set (filter_min_append xs ys)" and "rel y x" proof assume "x ∈ set xs" with False obtain y where "y ∈ set (filter_min_append xs ys)" and "rel y x" by (auto simp: filter_min_append_def P_def) thus ?thesis .. next assume "x ∈ set ys" with False obtain y where "y ∈ set xs" and "rel y x" by (auto simp: filter_min_append_def P_def) show ?thesis proof (cases "y ∈ set (filter_min_append xs ys)") case True thus ?thesis using ‹rel y x› .. next case False with ‹y ∈ set xs› obtain y' where y': "y' ∈ set (filter_min_append xs ys)" and "rel y' y" by (auto simp: filter_min_append_def P_def) from assms(1) this(2) ‹rel y x› have "rel y' x" by (rule transpD) with y' show ?thesis .. qed qed from this(1) False this(2) show ?thesis by (rule assms(4)) qed corollary filter_min_append_relE: assumes "transp rel" and "reflp rel" and "x ∈ set xs ∪ set ys" obtains y where "y ∈ set (filter_min_append xs ys)" and "rel y x" using assms(1, 3) proof (rule filter_min_append_cases) assume "x ∈ set (filter_min_append xs ys)" moreover from assms(2) have "rel x x" by (rule reflpD) ultimately show ?thesis .. qed lemma filter_min_append_minimal: assumes "⋀x' y'. x' ∈ set xs ⟹ y' ∈ set xs ⟹ rel x' y' ⟹ x' = y'" and "⋀x' y'. x' ∈ set ys ⟹ y' ∈ set ys ⟹ rel x' y' ⟹ x' = y'" and "x ∈ set (filter_min_append xs ys)" and "y ∈ set (filter_min_append xs ys)" and "rel x y" shows "x = y" proof - define P where "P = (λzs. λa. ¬ (∃z∈set zs. rel z a))" define ys1 where "ys1 = filter (P xs) ys" from assms(3) have "x ∈ set xs ∪ set ys1" by (auto simp: filter_min_append_def P_def ys1_def) moreover from assms(4) have "y ∈ set (filter (P ys1) xs) ∪ set ys1" by (simp add: filter_min_append_def P_def ys1_def) ultimately show ?thesis proof (elim UnE) assume "x ∈ set xs" assume "y ∈ set (filter (P ys1) xs)" hence "y ∈ set xs" by simp with ‹x ∈ set xs› show ?thesis using assms(5) by (rule assms(1)) next assume "y ∈ set ys1" hence "⋀z. z ∈ set xs ⟹ ¬ rel z y" by (simp add: ys1_def P_def) moreover assume "x ∈ set xs" ultimately have "¬ rel x y" by blast thus ?thesis using ‹rel x y› .. next assume "y ∈ set (filter (P ys1) xs)" hence "⋀z. z ∈ set ys1 ⟹ ¬ rel z y" by (simp add: P_def) moreover assume "x ∈ set ys1" ultimately have "¬ rel x y" by blast thus ?thesis using ‹rel x y› .. next assume "x ∈ set ys1" and "y ∈ set ys1" hence "x ∈ set ys" and "y ∈ set ys" by (simp_all add: ys1_def) thus ?thesis using assms(5) by (rule assms(2)) qed qed lemma filter_min_append_distinct: assumes "reflp rel" and "distinct xs" and "distinct ys" shows "distinct (filter_min_append xs ys)" proof - define P where "P = (λzs. λa. ¬ (∃z∈set zs. rel z a))" define ys1 where "ys1 = filter (P xs) ys" from assms(2) have "distinct (filter (P ys1) xs)" by simp moreover from assms(3) have "distinct ys1" by (simp add: ys1_def) moreover have "set (filter (P ys1) xs) ∩ set ys1 = {}" proof (simp add: set_eq_iff, intro allI impI notI) fix x assume "P ys1 x" hence "⋀z. z ∈ set ys1 ⟹ ¬ rel z x" by (simp add: P_def) moreover assume "x ∈ set ys1" ultimately have "¬ rel x x" by blast moreover from assms(1) have "rel x x" by (rule reflpD) ultimately show False .. qed ultimately show ?thesis by (simp add: filter_min_append_def ys1_def P_def) qed end end (* theory *)
Theory Confluence
(* Author: Fabian Immler, Alexander Maletzky *) section ‹Properties of Binary Relations› theory Confluence imports "Abstract-Rewriting.Abstract_Rewriting" "Open_Induction.Restricted_Predicates" begin text ‹This theory formalizes some general properties of binary relations, in particular a very weak sufficient condition for a relation to be Church-Rosser.› (* Maybe one could build upon "Decreasing_Diagrams" / "Decreasing_Diagrams_II" from the AFP? *) subsection ‹@{const wfp_on}› (* Probably the converse direction holds, too. *) lemma wfp_on_imp_wfP: assumes "wfp_on r A" shows "wfP (λx y. r x y ∧ x ∈ A ∧ y ∈ A)" (is "wfP ?r") proof (simp add: wfP_def wf_def, intro allI impI) fix P x assume "∀x. (∀y. r y x ∧ y ∈ A ∧ x ∈ A ⟶ P y) ⟶ P x" hence *: "⋀x. (⋀y. x ∈ A ⟹ y ∈ A ⟹ r y x ⟹ P y) ⟹ P x" by blast from assms have **: "⋀a. a ∈ A ⟹ (⋀x. x ∈ A ⟹ (⋀y. y ∈ A ⟹ r y x ⟹ P y) ⟹ P x) ⟹ P a" by (rule wfp_on_induct) blast+ show "P x" proof (cases "x ∈ A") case True from this * show ?thesis by (rule **) next case False show ?thesis proof (rule *) fix y assume "x ∈ A" with False show "P y" .. qed qed qed lemma wfp_onI_min: assumes "⋀x Q. x ∈ Q ⟹ Q ⊆ A ⟹ ∃z∈Q. ∀y∈A. r y z ⟶ y ∉ Q" shows "wfp_on r A" proof (intro inductive_on_imp_wfp_on minimal_imp_inductive_on allI impI) fix Q x assume "x ∈ Q ∧ Q ⊆ A" hence "x ∈ Q" and "Q ⊆ A" by simp_all hence "∃z∈Q. ∀y∈A. r y z ⟶ y ∉ Q" by (rule assms) then obtain z where "z ∈ Q" and 1: "⋀y. y ∈ A ⟹ r y z ⟹ y ∉ Q" by blast show "∃z∈Q. ∀y. r y z ⟶ y ∉ Q" proof (intro bexI allI impI) fix y assume "r y z" show "y ∉ Q" proof (cases "y ∈ A") case True thus ?thesis using ‹r y z› by (rule 1) next case False with ‹Q ⊆ A› show ?thesis by blast qed qed fact qed lemma wfp_onE_min: assumes "wfp_on r A" and "x ∈ Q" and "Q ⊆ A" obtains z where "z ∈ Q" and "⋀y. r y z ⟹ y ∉ Q" using wfp_on_imp_minimal[OF assms(1)] assms(2, 3) by blast lemma wfp_onI_chain: "¬ (∃f. ∀i. f i ∈ A ∧ r (f (Suc i)) (f i)) ⟹ wfp_on r A" by (simp add: wfp_on_def) lemma finite_minimalE: assumes "finite A" and "A ≠ {}" and "irreflp rel" and "transp rel" obtains a where "a ∈ A" and "⋀b. rel b a ⟹ b ∉ A" using assms(1, 2) proof (induct arbitrary: thesis) case empty from empty(2) show ?case by simp next case (insert a A) show ?case proof (cases "A = {}") case True show ?thesis proof (rule insert(4)) fix b assume "rel b a" with assms(3) show "b ∉ insert a A" by (auto simp: True irreflp_def) qed simp next case False with insert(3) obtain z where "z ∈ A" and *: "⋀b. rel b z ⟹ b ∉ A" by blast show ?thesis proof (cases "rel a z") case True show ?thesis proof (rule insert(4)) fix b assume "rel b a" with assms(4) have "rel b z" using ‹rel a z› by (rule transpD) hence "b ∉ A" by (rule *) moreover from ‹rel b a› assms(3) have "b ≠ a" by (auto simp: irreflp_def) ultimately show "b ∉ insert a A" by simp qed simp next case False show ?thesis proof (rule insert(4)) fix b assume "rel b z" hence "b ∉ A" by (rule *) moreover from ‹rel b z› False have "b ≠ a" by blast ultimately show "b ∉ insert a A" by simp next from ‹z ∈ A› show "z ∈ insert a A" by simp qed qed qed qed lemma wfp_on_finite: assumes "irreflp rel" and "transp rel" and "finite A" shows "wfp_on rel A" proof (rule wfp_onI_min) fix x Q assume "x ∈ Q" and "Q ⊆ A" from this(2) assms(3) have "finite Q" by (rule finite_subset) moreover from ‹x ∈ Q› have "Q ≠ {}" by blast ultimately obtain z where "z ∈ Q" and "⋀y. rel y z ⟹ y ∉ Q" using assms(1, 2) by (rule finite_minimalE) blast thus "∃z∈Q. ∀y∈A. rel y z ⟶ y ∉ Q" by blast qed subsection ‹Relations› locale relation = fixes r::"'a ⇒ 'a ⇒ bool" (infixl "→" 50) begin abbreviation rtc::"'a ⇒ 'a ⇒ bool" (infixl "→⇧*" 50) where "rtc a b ≡ r⇧*⇧* a b" abbreviation sc::"'a ⇒ 'a ⇒ bool" (infixl "↔" 50) where "sc a b ≡ a → b ∨ b → a" definition is_final::"'a ⇒ bool" where "is_final a ≡ ¬ (∃b. r a b)" definition srtc::"'a ⇒ 'a ⇒ bool" (infixl "↔⇧*" 50) where "srtc a b ≡ sc⇧*⇧* a b" definition cs::"'a ⇒ 'a ⇒ bool" (infixl "↓⇧*" 50) where "cs a b ≡ (∃s. (a →⇧* s) ∧ (b →⇧* s))" definition is_confluent_on :: "'a set ⇒ bool" where "is_confluent_on A ⟷ (∀a∈A. ∀b1 b2. (a →⇧* b1 ∧ a →⇧* b2) ⟶ b1 ↓⇧* b2)" definition is_confluent :: bool where "is_confluent ≡ is_confluent_on UNIV" definition is_loc_confluent :: bool where "is_loc_confluent ≡ (∀a b1 b2. (a → b1 ∧ a → b2) ⟶ b1 ↓⇧* b2)" definition is_ChurchRosser :: bool where "is_ChurchRosser ≡ (∀a b. a ↔⇧* b ⟶ a ↓⇧* b)" definition dw_closed :: "'a set ⇒ bool" where "dw_closed A ⟷ (∀a∈A. ∀b. a → b ⟶ b ∈ A)" lemma dw_closedI [intro]: assumes "⋀a b. a ∈ A ⟹ a → b ⟹ b ∈ A" shows "dw_closed A" unfolding dw_closed_def using assms by auto lemma dw_closedD: assumes "dw_closed A" and "a ∈ A" and "a → b" shows "b ∈ A" using assms unfolding dw_closed_def by auto lemma dw_closed_rtrancl: assumes "dw_closed A" and "a ∈ A" and "a →⇧* b" shows "b ∈ A" using assms(3) proof (induct b) case base from assms(2) show ?case . next case (step y z) from assms(1) step(3) step(2) show ?case by (rule dw_closedD) qed lemma dw_closed_empty: "dw_closed {}" by (rule, simp) lemma dw_closed_UNIV: "dw_closed UNIV" by (rule, intro UNIV_I) subsection ‹Setup for Connection to Theory @{theory "Abstract-Rewriting.Abstract_Rewriting"}› abbreviation (input) relset::"('a * 'a) set" where "relset ≡ {(x, y). x → y}" lemma rtc_rtranclI: assumes "a →⇧* b" shows "(a, b) ∈ relset⇧*" using assms by (simp only: Enum.rtranclp_rtrancl_eq) lemma final_NF: "(is_final a) = (a ∈ NF relset)" unfolding is_final_def NF_def by simp lemma sc_symcl: "(a ↔ b) = ((a, b) ∈ relset⇧↔)" by simp lemma srtc_conversion: "(a ↔⇧* b) = ((a, b) ∈ relset⇧↔⇧*)" proof - have "{(a, b). (a, b) ∈ {(x, y). x → y}⇧↔} = {(a, b). a → b}⇧↔" by auto thus ?thesis unfolding srtc_def conversion_def sc_symcl Enum.rtranclp_rtrancl_eq by simp qed lemma cs_join: "(a ↓⇧* b) = ((a, b) ∈ relset⇧↓)" unfolding cs_def join_def by (auto simp add: Enum.rtranclp_rtrancl_eq rtrancl_converse) lemma confluent_CR: "is_confluent = CR relset" by (auto simp add: is_confluent_def is_confluent_on_def CR_defs Enum.rtranclp_rtrancl_eq cs_join) lemma ChurchRosser_conversion: "is_ChurchRosser = (relset⇧↔⇧* ⊆ relset⇧↓)" by (auto simp add: is_ChurchRosser_def cs_join srtc_conversion) lemma loc_confluent_WCR: shows "is_loc_confluent = WCR relset" unfolding is_loc_confluent_def WCR_defs by (auto simp add: cs_join) lemma wf_converse: shows "(wfP r^--1) = (wf (relset¯))" unfolding wfP_def converse_def by simp lemma wf_SN: shows "(wfP r^--1) = (SN relset)" unfolding wf_converse wf_iff_no_infinite_down_chain SN_on_def by auto subsection ‹Simple Lemmas› lemma rtrancl_is_final: assumes "a →⇧* b" and "is_final a" shows "a = b" proof - from rtranclpD[OF ‹a →⇧* b›] show ?thesis proof assume "a ≠ b ∧ (→)⇧+⇧+ a b" hence "(→)⇧+⇧+ a b" by simp from ‹is_final a› final_NF have "a ∈ NF relset" by simp from NF_no_trancl_step[OF this] have "(a, b) ∉ {(x, y). x → y}⇧+" .. thus ?thesis using ‹(→)⇧+⇧+ a b› unfolding tranclp_unfold .. qed qed lemma cs_refl: shows "x ↓⇧* x" unfolding cs_def proof show "x →⇧* x ∧ x →⇧* x" by simp qed lemma cs_sym: assumes "x ↓⇧* y" shows "y ↓⇧* x" using assms unfolding cs_def proof fix z assume a: "x →⇧* z ∧ y →⇧* z" show "∃s. y →⇧* s ∧ x →⇧* s" proof from a show "y →⇧* z ∧ x →⇧* z" by simp qed qed lemma rtc_implies_cs: assumes "x →⇧* y" shows "x ↓⇧* y" proof - from joinI_left[OF rtc_rtranclI[OF assms]] cs_join show ?thesis by simp qed lemma rtc_implies_srtc: assumes "a →⇧* b" shows "a ↔⇧* b" proof - from conversionI'[OF rtc_rtranclI[OF assms]] srtc_conversion show ?thesis by simp qed lemma srtc_symmetric: assumes "a ↔⇧* b" shows "b ↔⇧* a" proof - from symD[OF conversion_sym[of relset], of a b] assms srtc_conversion show ?thesis by simp qed lemma srtc_transitive: assumes "a ↔⇧* b" and "b ↔⇧* c" shows "a ↔⇧* c" proof - from rtranclp_trans[of "(↔)" a b c] assms show "a ↔⇧* c" unfolding srtc_def . qed lemma cs_implies_srtc: assumes "a ↓⇧* b" shows "a ↔⇧* b" proof - from assms cs_join have "(a, b) ∈ relset⇧↓" by simp hence "(a, b) ∈ relset⇧↔⇧*" using join_imp_conversion by auto thus ?thesis using srtc_conversion by simp qed lemma confluence_equiv_ChurchRosser: "is_confluent = is_ChurchRosser" by (simp only: ChurchRosser_conversion confluent_CR, fact CR_iff_conversion_imp_join) corollary confluence_implies_ChurchRosser: assumes is_confluent shows is_ChurchRosser using assms by (simp only: confluence_equiv_ChurchRosser) lemma ChurchRosser_unique_final: assumes "is_ChurchRosser" and "a →⇧* b1" and "a →⇧* b2" and "is_final b1" and "is_final b2" shows "b1 = b2" proof - from ‹is_ChurchRosser› confluence_equiv_ChurchRosser confluent_CR have "CR relset" by simp from CR_imp_UNF[OF this] assms show ?thesis unfolding UNF_defs normalizability_def by (auto simp add: Enum.rtranclp_rtrancl_eq final_NF) qed lemma wf_on_imp_nf_ex: assumes "wfp_on ((→)¯¯) A" and "dw_closed A" and "a ∈ A" obtains b where "a →⇧* b" and "is_final b" proof - let ?A = "{b∈A. a →⇧* b}" note assms(1) moreover from assms(3) have "a ∈ ?A" by simp moreover have "?A ⊆ A" by auto ultimately show ?thesis proof (rule wfp_onE_min) fix z assume "z ∈ ?A" and "⋀y. (→)¯¯ y z ⟹ y ∉ ?A" from this(2) have *: "⋀y. z → y ⟹ y ∉ ?A" by simp from ‹z ∈ ?A› have "z ∈ A" and "a →⇧* z" by simp_all show thesis proof (rule, fact) show "is_final z" unfolding is_final_def proof assume "∃y. z → y" then obtain y where "z → y" .. hence "y ∉ ?A" by (rule *) moreover from assms(2) ‹z ∈ A› ‹z → y› have "y ∈ A" by (rule dw_closedD) ultimately have "¬ (a →⇧* y)" by simp with rtranclp_trans[OF ‹a →⇧* z›, of y] ‹z → y› show False by auto qed qed qed qed lemma unique_nf_imp_confluence_on: assumes major: "⋀a b1 b2. a ∈ A ⟹ (a →⇧* b1) ⟹ (a →⇧* b2) ⟹ is_final b1 ⟹ is_final b2 ⟹ b1 = b2" and wf: "wfp_on ((→)¯¯) A" and dw: "dw_closed A" shows "is_confluent_on A" unfolding is_confluent_on_def proof (intro ballI allI impI) fix a b1 b2 assume "a →⇧* b1 ∧ a →⇧* b2" hence "a →⇧* b1" and "a →⇧* b2" by simp_all assume "a ∈ A" from dw this ‹a →⇧* b1› have "b1 ∈ A" by (rule dw_closed_rtrancl) from wf dw this obtain c1 where "b1 →⇧* c1" and "is_final c1" by (rule wf_on_imp_nf_ex) from dw ‹a ∈ A› ‹a →⇧* b2› have "b2 ∈ A" by (rule dw_closed_rtrancl) from wf dw this obtain c2 where "b2 →⇧* c2" and "is_final c2" by (rule wf_on_imp_nf_ex) have "c1 = c2" by (rule major, fact, rule rtranclp_trans[OF ‹a →⇧* b1›], fact, rule rtranclp_trans[OF ‹a →⇧* b2›], fact+) show "b1 ↓⇧* b2" unfolding cs_def proof (intro exI, intro conjI) show "b1 →⇧* c1" by fact next show "b2 →⇧* c1" unfolding ‹c1 = c2› by fact qed qed corollary wf_imp_nf_ex: assumes "wfP ((→)¯¯)" obtains b where "a →⇧* b" and "is_final b" proof - from assms have "wfp_on (r^--1) UNIV" by simp moreover note dw_closed_UNIV moreover have "a ∈ UNIV" .. ultimately obtain b where "a →⇧* b" and "is_final b" by (rule wf_on_imp_nf_ex) thus ?thesis .. qed corollary unique_nf_imp_confluence: assumes "⋀a b1 b2. (a →⇧* b1) ⟹ (a →⇧* b2) ⟹ is_final b1 ⟹ is_final b2 ⟹ b1 = b2" and "wfP ((→)¯¯)" shows "is_confluent" unfolding is_confluent_def by (rule unique_nf_imp_confluence_on, erule assms(1), assumption+, simp add: assms(2), fact dw_closed_UNIV) end (*relation*) subsection ‹Advanced Results and the Generalized Newman Lemma› definition relbelow_on :: "'a set ⇒ ('a ⇒ 'a ⇒ bool) ⇒ 'a ⇒ ('a ⇒ 'a ⇒ bool) ⇒ ('a ⇒ 'a ⇒ bool)" where "relbelow_on A ord z rel a b ≡ (a ∈ A ∧ b ∈ A ∧ rel a b ∧ ord a z ∧ ord b z)" definition cbelow_on_1 :: "'a set ⇒ ('a ⇒ 'a ⇒ bool) ⇒ 'a ⇒ ('a ⇒ 'a ⇒ bool) ⇒ ('a ⇒ 'a ⇒ bool)" where "cbelow_on_1 A ord z rel ≡ (relbelow_on A ord z rel)⇧+⇧+" definition cbelow_on :: "'a set ⇒ ('a ⇒ 'a ⇒ bool) ⇒ 'a ⇒ ('a ⇒ 'a ⇒ bool) ⇒ ('a ⇒ 'a ⇒ bool)" where "cbelow_on A ord z rel a b ≡ (a = b ∧ b ∈ A ∧ ord b z) ∨ cbelow_on_1 A ord z rel a b" text ‹Note that @{const cbelow_on} cannot be defined as the reflexive-transitive closure of @{const relbelow_on}, since it is in general not reflexive!› definition is_loc_connective_on :: "'a set ⇒ ('a ⇒ 'a ⇒ bool) ⇒ ('a ⇒ 'a ⇒ bool) ⇒ bool" where "is_loc_connective_on A ord r ⟷ (∀a∈A. ∀b1 b2. r a b1 ∧ r a b2 ⟶ cbelow_on A ord a (relation.sc r) b1 b2)" text ‹Note that @{const wfp_on} is @{emph ‹not›} the same as @{const SN_on}, since in the definition of @{const SN_on} only the @{emph ‹first›} element of the chain must be in the set.› lemma cbelow_on_first_below: assumes "cbelow_on A ord z rel a b" shows "ord a z" using assms unfolding cbelow_on_def proof assume "cbelow_on_1 A ord z rel a b" thus "ord a z" unfolding cbelow_on_1_def by (induct rule: tranclp_induct, simp add: relbelow_on_def) qed simp lemma cbelow_on_second_below: assumes "cbelow_on A ord z rel a b" shows "ord b z" using assms unfolding cbelow_on_def proof assume "cbelow_on_1 A ord z rel a b" thus "ord b z" unfolding cbelow_on_1_def by (induct rule: tranclp_induct, simp_all add: relbelow_on_def) qed simp lemma cbelow_on_first_in: assumes "cbelow_on A ord z rel a b" shows "a ∈ A" using assms unfolding cbelow_on_def proof assume "cbelow_on_1 A ord z rel a b" thus ?thesis unfolding cbelow_on_1_def by (induct rule: tranclp_induct, simp add: relbelow_on_def) qed simp lemma cbelow_on_second_in: assumes "cbelow_on A ord z rel a b" shows "b ∈ A" using assms unfolding cbelow_on_def proof assume "cbelow_on_1 A ord z rel a b" thus ?thesis unfolding cbelow_on_1_def by (induct rule: tranclp_induct, simp_all add: relbelow_on_def) qed simp lemma cbelow_on_intro [intro]: assumes main: "cbelow_on A ord z rel a b" and "c ∈ A" and "rel b c" and "ord c z" shows "cbelow_on A ord z rel a c" proof - from main have "b ∈ A" by (rule cbelow_on_second_in) from main show ?thesis unfolding cbelow_on_def proof (intro disjI2) assume cases: "(a = b ∧ b ∈ A ∧ ord b z) ∨ cbelow_on_1 A ord z rel a b" from ‹b ∈ A› ‹c ∈ A› ‹rel b c› ‹ord c z› cbelow_on_second_below[OF main] have bc: "relbelow_on A ord z rel b c" by (simp add: relbelow_on_def) from cases show "cbelow_on_1 A ord z rel a c" proof assume "a = b ∧ b ∈ A ∧ ord b z" from this bc have "relbelow_on A ord z rel a c" by simp thus ?thesis by (simp add: cbelow_on_1_def) next assume "cbelow_on_1 A ord z rel a b" from this bc show ?thesis unfolding cbelow_on_1_def by (rule tranclp.intros(2)) qed qed qed lemma cbelow_on_induct [consumes 1, case_names base step]: assumes a: "cbelow_on A ord z rel a b" and base: "a ∈ A ⟹ ord a z ⟹ P a" and ind: "⋀b c. [| cbelow_on A ord z rel a b; rel b c; c ∈ A; ord c z; P b |] ==> P c" shows "P b" using a unfolding cbelow_on_def proof assume "a = b ∧ b ∈ A ∧ ord b z" from this base show "P b" by simp next assume "cbelow_on_1 A ord z rel a b" thus "P b" unfolding cbelow_on_1_def proof (induct x≡a b) fix b assume "relbelow_on A ord z rel a b" hence "rel a b" and "a ∈ A" and "b ∈ A" and "ord a z" and "ord b z" by (simp_all add: relbelow_on_def) hence "cbelow_on A ord z rel a a" by (simp add: cbelow_on_def) from this ‹rel a b› ‹b ∈ A› ‹ord b z› base[OF ‹a ∈ A› ‹ord a z›] show "P b" by (rule ind) next fix b c assume IH: "(relbelow_on A ord z rel)⇧+⇧+ a b" and "P b" and "relbelow_on A ord z rel b c" hence "rel b c" and "b ∈ A" and "c ∈ A" and "ord b z" and "ord c z" by (simp_all add: relbelow_on_def) from IH have "cbelow_on A ord z rel a b" by (simp add: cbelow_on_def cbelow_on_1_def) from this ‹rel b c› ‹c ∈ A› ‹ord c z› ‹P b› show "P c" by (rule ind) qed qed lemma cbelow_on_symmetric: assumes main: "cbelow_on A ord z rel a b" and "symp rel" shows "cbelow_on A ord z rel b a" using main unfolding cbelow_on_def proof assume a1: "a = b ∧ b ∈ A ∧ ord b z" show "b = a ∧ a ∈ A ∧ ord a z ∨ cbelow_on_1 A ord z rel b a" proof from a1 show "b = a ∧ a ∈ A ∧ ord a z" by simp qed next assume a2: "cbelow_on_1 A ord z rel a b" show "b = a ∧ a ∈ A ∧ ord a z ∨ cbelow_on_1 A ord z rel b a" proof (rule disjI2) from ‹symp rel› have "symp (relbelow_on A ord z rel)" unfolding symp_def proof (intro allI impI) fix x y assume rel_sym: "∀x y. rel x y ⟶ rel y x" assume "relbelow_on A ord z rel x y" hence "rel x y" and "x ∈ A" and "y ∈ A" and "ord x z" and "ord y z" by (simp_all add: relbelow_on_def) show "relbelow_on A ord z rel y x" unfolding relbelow_on_def proof (intro conjI) from rel_sym ‹rel x y› show "rel y x" by simp qed fact+ qed from sym_trancl[to_pred, OF this] a2 show "cbelow_on_1 A ord z rel b a" by (simp add: symp_def cbelow_on_1_def) qed qed lemma cbelow_on_transitive: assumes "cbelow_on A ord z rel a b" and "cbelow_on A ord z rel b c" shows "cbelow_on A ord z rel a c" proof (induct rule: cbelow_on_induct[OF ‹cbelow_on A ord z rel b c›]) from ‹cbelow_on A ord z rel a b› show "cbelow_on A ord z rel a b" . next fix c0 c assume "cbelow_on A ord z rel b c0" and "rel c0 c" and "c ∈ A" and "ord c z" and "cbelow_on A ord z rel a c0" show "cbelow_on A ord z rel a c" by (rule, fact+) qed lemma cbelow_on_mono: assumes "cbelow_on A ord z rel a b" and "A ⊆ B" shows "cbelow_on B ord z rel a b" using assms(1) proof (induct rule: cbelow_on_induct) case base show ?case by (simp add: cbelow_on_def, intro disjI1 conjI, rule, fact+) next case (step b c) from step(3) assms(2) have "c ∈ B" .. from step(5) this step(2) step (4) show ?case .. qed locale relation_order = relation + fixes ord::"'a ⇒ 'a ⇒ bool" fixes A::"'a set" assumes trans: "ord x y ⟹ ord y z ⟹ ord x z" assumes wf: "wfp_on ord A" assumes refines: "(→) ≤ ord¯¯" begin lemma relation_refines: assumes "a → b" shows "ord b a" using refines assms by auto lemma relation_wf: "wfp_on (→)¯¯ A" using subset_refl _ wf proof (rule wfp_on_mono) fix x y assume "(→)¯¯ x y" hence "y → x" by simp with refines have "(ord)¯¯ y x" .. thus "ord x y" by simp qed lemma rtc_implies_cbelow_on: assumes "dw_closed A" and main: "a →⇧* b" and "a ∈ A" and "ord a c" shows "cbelow_on A ord c (↔) a b" using main proof (induct rule: rtranclp_induct) from assms(3) assms(4) show "cbelow_on A ord c (↔) a a" by (simp add: cbelow_on_def) next fix b0 b assume "a →⇧* b0" and "b0 → b" and IH: "cbelow_on A ord c (↔) a b0" from assms(1) assms(3) ‹a →⇧* b0› have "b0 ∈ A" by (rule dw_closed_rtrancl) from assms(1) this ‹b0 → b› have "b ∈ A" by (rule dw_closedD) show "cbelow_on A ord c (↔) a b" proof from ‹b0 → b› show "b0 ↔ b" by simp next from relation_refines[OF ‹b0 → b›] cbelow_on_second_below[OF IH] show "ord b c" by (rule trans) qed fact+ qed lemma cs_implies_cbelow_on: assumes "dw_closed A" and "a ↓⇧* b" and "a ∈ A" and "b ∈ A" and "ord a c" and "ord b c" shows "cbelow_on A ord c (↔) a b" proof - from ‹a ↓⇧* b› obtain s where "a →⇧* s" and "b →⇧* s" unfolding cs_def by auto have sym: "symp (↔)" unfolding symp_def proof (intro allI, intro impI) fix x y assume "x ↔ y" thus "y ↔ x" by auto qed from assms(1) ‹a →⇧* s› assms(3) assms(5) have "cbelow_on A ord c (↔) a s" by (rule rtc_implies_cbelow_on) also have "cbelow_on A ord c (↔) s b" proof (rule cbelow_on_symmetric) from assms(1) ‹b →⇧* s› assms(4) assms(6) show "cbelow_on A ord c (↔) b s" by (rule rtc_implies_cbelow_on) qed fact finally(cbelow_on_transitive) show ?thesis . qed text ‹The generalized Newman lemma, taken from @{cite Winkler1983}:› lemma loc_connectivity_implies_confluence: assumes "is_loc_connective_on A ord (→)" and "dw_closed A" shows "is_confluent_on A" using assms(1) unfolding is_loc_connective_on_def is_confluent_on_def proof (intro ballI allI impI) fix z x y::'a assume "∀a∈A. ∀b1 b2. a → b1 ∧ a → b2 ⟶ cbelow_on A ord a (↔) b1 b2" hence A: "⋀a b1 b2. a ∈ A ⟹ a → b1 ⟹ a → b2 ⟹ cbelow_on A ord a (↔) b1 b2" by simp assume "z ∈ A" and "z →⇧* x ∧ z →⇧* y" with wf show "x ↓⇧* y" proof (induct z arbitrary: x y rule: wfp_on_induct) fix z x y::'a assume IH: "⋀z0 x0 y0. z0 ∈ A ⟹ ord z0 z ⟹ z0 →⇧* x0 ∧ z0 →⇧* y0 ⟹ x0 ↓⇧* y0" and "z →⇧* x ∧ z →⇧* y" hence "z →⇧* x" and "z →⇧* y" by auto assume "z ∈ A" from converse_rtranclpE[OF ‹z →⇧* x›] obtain x1 where "x = z ∨ (z → x1 ∧ x1 →⇧* x)" by auto thus "x ↓⇧* y" proof assume "x = z" show ?thesis unfolding cs_def proof from ‹x = z› ‹z →⇧* y› show "x →⇧* y ∧ y →⇧* y" by simp qed next assume "z → x1 ∧ x1 →⇧* x" hence "z → x1" and "x1 →⇧* x" by auto from assms(2) ‹z ∈ A› this(1) have "x1 ∈ A" by (rule dw_closedD) from converse_rtranclpE[OF ‹z →⇧* y›] obtain y1 where "y = z ∨ (z → y1 ∧ y1 →⇧* y)" by auto thus ?thesis proof assume "y = z" show ?thesis unfolding cs_def proof from ‹y = z› ‹z →⇧* x› show "x →⇧* x ∧ y →⇧* x" by simp qed next assume "z → y1 ∧ y1 →⇧* y" hence "z → y1" and "y1 →⇧* y" by auto from assms(2) ‹z ∈ A› this(1) have "y1 ∈ A" by (rule dw_closedD) have "x1 ↓⇧* y1" proof (induct rule: cbelow_on_induct[OF A[OF ‹z ∈ A› ‹z → x1› ‹z → y1›]]) from cs_refl[of x1] show "x1 ↓⇧* x1" . next fix b c assume "cbelow_on A ord z (↔) x1 b" and "b ↔ c" and "c ∈ A" and "ord c z" and "x1 ↓⇧* b" from this(1) have "b ∈ A" by (rule cbelow_on_second_in) from ‹x1 ↓⇧* b› obtain w1 where "x1 →⇧* w1" and "b →⇧* w1" unfolding cs_def by auto from ‹b ↔ c› show "x1 ↓⇧* c" proof assume "b → c" hence "b →⇧* c" by simp from ‹cbelow_on A ord z (↔) x1 b› have "ord b z" by (rule cbelow_on_second_below) from IH[OF ‹b ∈ A› this] ‹b →⇧* c› ‹b →⇧* w1› have "c ↓⇧* w1" by simp then obtain w2 where "c →⇧* w2" and "w1 →⇧* w2" unfolding cs_def by auto show ?thesis unfolding cs_def proof from rtranclp_trans[OF ‹x1 →⇧* w1› ‹w1 →⇧* w2›] ‹c →⇧* w2› show "x1 →⇧* w2 ∧ c →⇧* w2" by simp qed next assume "c → b" hence "c →⇧* b" by simp show ?thesis unfolding cs_def proof from rtranclp_trans[OF ‹c →⇧* b› ‹b →⇧* w1›] ‹x1 →⇧* w1› show "x1 →⇧* w1 ∧ c →⇧* w1" by simp qed qed qed then obtain w1 where "x1 →⇧* w1" and "y1 →⇧* w1" unfolding cs_def by auto from IH[OF ‹x1 ∈ A› relation_refines[OF ‹z → x1›]] ‹x1 →⇧* x› ‹x1 →⇧* w1› have "x ↓⇧* w1" by simp then obtain v where "x →⇧* v" and "w1 →⇧* v" unfolding cs_def by auto from IH[OF ‹y1 ∈ A› relation_refines[OF ‹z → y1›]] rtranclp_trans[OF ‹y1 →⇧* w1› ‹w1 →⇧* v›] ‹y1 →⇧* y› have "v ↓⇧* y" by simp then obtain w where "v →⇧* w" and "y →⇧* w" unfolding cs_def by auto show ?thesis unfolding cs_def proof from rtranclp_trans[OF ‹x →⇧* v› ‹v →⇧* w›] ‹y →⇧* w› show "x →⇧* w ∧ y →⇧* w" by simp qed qed qed qed qed end (* relation_order *) theorem loc_connectivity_equiv_ChurchRosser: assumes "relation_order r ord UNIV" shows "relation.is_ChurchRosser r = is_loc_connective_on UNIV ord r" proof assume "relation.is_ChurchRosser r" show "is_loc_connective_on UNIV ord r" unfolding is_loc_connective_on_def proof (intro ballI allI impI) fix a b1 b2 assume "r a b1 ∧ r a b2" hence "r a b1" and "r a b2" by simp_all hence "r⇧*⇧* a b1" and "r⇧*⇧* a b2" by simp_all from relation.rtc_implies_srtc[OF ‹r⇧*⇧* a b1›] have "relation.srtc r b1 a" by (rule relation.srtc_symmetric) from relation.srtc_transitive[OF this relation.rtc_implies_srtc[OF ‹r⇧*⇧* a b2›]] have "relation.srtc r b1 b2" . with ‹relation.is_ChurchRosser r› have "relation.cs r b1 b2" by (simp add: relation.is_ChurchRosser_def) from relation_order.cs_implies_cbelow_on[OF assms relation.dw_closed_UNIV this] relation_order.relation_refines[OF assms, of a] ‹r a b1› ‹r a b2› show "cbelow_on UNIV ord a (relation.sc r) b1 b2" by simp qed next assume "is_loc_connective_on UNIV ord r" from assms this relation.dw_closed_UNIV have "relation.is_confluent_on r UNIV" by (rule relation_order.loc_connectivity_implies_confluence) hence "relation.is_confluent r" by (simp only: relation.is_confluent_def) thus "relation.is_ChurchRosser r" by (simp add: relation.confluence_equiv_ChurchRosser) qed end
Theory Reduction
(* Author: Fabian Immler, Alexander Maletzky *) section ‹Polynomial Reduction› theory Reduction imports "Polynomials.MPoly_Type_Class_Ordered" Confluence begin text ‹This theory formalizes the concept of @{emph ‹reduction›} of polynomials by polynomials.› context ordered_term begin definition red_single :: "('t ⇒⇩0 'b::field) ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b) ⇒ 'a ⇒ bool" where "red_single p q f t ⟷ (f ≠ 0 ∧ lookup p (t ⊕ lt f) ≠ 0 ∧ q = p - monom_mult ((lookup p (t ⊕ lt f)) / lc f) t f)" definition red :: "('t ⇒⇩0 'b::field) set ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b) ⇒ bool" where "red F p q ⟷ (∃f∈F. ∃t. red_single p q f t)" definition is_red :: "('t ⇒⇩0 'b::field) set ⇒ ('t ⇒⇩0 'b) ⇒ bool" where "is_red F a ⟷ ¬ relation.is_final (red F) a" subsection ‹Basic Properties of Reduction› lemma red_setI: assumes "f ∈ F" and a: "red_single p q f t" shows "red F p q" unfolding red_def proof from ‹f ∈ F› show "f ∈ F" . next from a show "∃t. red_single p q f t" .. qed lemma red_setE: assumes "red F p q" obtains f and t where "f ∈ F" and "red_single p q f t" proof - from assms obtain f where "f ∈ F" and t: "∃t. red_single p q f t" unfolding red_def by auto from t obtain t where "red_single p q f t" .. from ‹f ∈ F› this show "?thesis" .. qed lemma red_empty: "¬ red {} p q" by (rule, elim red_setE, simp) lemma red_singleton_zero: "¬ red {0} p q" by (rule, elim red_setE, simp add: red_single_def) lemma red_union: "red (F ∪ G) p q = (red F p q ∨ red G p q)" proof assume "red (F ∪ G) p q" from red_setE[OF this] obtain f t where "f ∈ F ∪ G" and r: "red_single p q f t" . from ‹f ∈ F ∪ G› have "f ∈ F ∨ f ∈ G" by simp thus "red F p q ∨ red G p q" proof assume "f ∈ F" show ?thesis by (intro disjI1, rule red_setI[OF ‹f ∈ F› r]) next assume "f ∈ G" show ?thesis by (intro disjI2, rule red_setI[OF ‹f ∈ G› r]) qed next assume "red F p q ∨ red G p q" thus "red (F ∪ G) p q" proof assume "red F p q" from red_setE[OF this] obtain f t where "f ∈ F" and "red_single p q f t" . show ?thesis by (intro red_setI[of f _ _ _ t], rule UnI1, rule ‹f ∈ F›, fact) next assume "red G p q" from red_setE[OF this] obtain f t where "f ∈ G" and "red_single p q f t" . show ?thesis by (intro red_setI[of f _ _ _ t], rule UnI2, rule ‹f ∈ G›, fact) qed qed lemma red_unionI1: assumes "red F p q" shows "red (F ∪ G) p q" unfolding red_union by (rule disjI1, fact) lemma red_unionI2: assumes "red G p q" shows "red (F ∪ G) p q" unfolding red_union by (rule disjI2, fact) lemma red_subset: assumes "red G p q" and "G ⊆ F" shows "red F p q" proof - from ‹G ⊆ F› obtain H where "F = G ∪ H" by auto show ?thesis unfolding ‹F = G ∪ H› by (rule red_unionI1, fact) qed lemma red_union_singleton_zero: "red (F ∪ {0}) = red F" by (intro ext, simp only: red_union red_singleton_zero, simp) lemma red_minus_singleton_zero: "red (F - {0}) = red F" by (metis Un_Diff_cancel2 red_union_singleton_zero) lemma red_rtrancl_subset: assumes major: "(red G)⇧*⇧* p q" and "G ⊆ F" shows "(red F)⇧*⇧* p q" using major proof (induct rule: rtranclp_induct) show "(red F)⇧*⇧* p p" .. next fix r q assume "red G r q" and "(red F)⇧*⇧* p r" show "(red F)⇧*⇧* p q" proof show "(red F)⇧*⇧* p r" by fact next from red_subset[OF ‹red G r q› ‹G ⊆ F›] show "red F r q" . qed qed lemma red_singleton: "red {f} p q ⟷ (∃t. red_single p q f t)" unfolding red_def proof assume "∃f∈{f}. ∃t. red_single p q f t" from this obtain f0 where "f0 ∈ {f}" and a: "∃t. red_single p q f0 t" .. from ‹f0 ∈ {f}› have "f0 = f" by simp from this a show "∃t. red_single p q f t" by simp next assume a: "∃t. red_single p q f t" show "∃f∈{f}. ∃t. red_single p q f t" proof (rule, simp) from a show "∃t. red_single p q f t" . qed qed lemma red_single_lookup: assumes "red_single p q f t" shows "lookup q (t ⊕ lt f) = 0" using assms unfolding red_single_def proof assume "f ≠ 0" and "lookup p (t ⊕ lt f) ≠ 0 ∧ q = p - monom_mult (lookup p (t ⊕ lt f) / lc f) t f" hence "lookup p (t ⊕ lt f) ≠ 0" and q_def: "q = p - monom_mult (lookup p (t ⊕ lt f) / lc f) t f" by auto from lookup_minus[of p "monom_mult (lookup p (t ⊕ lt f) / lc f) t f" "t ⊕ lt f"] lookup_monom_mult_plus[of "lookup p (t ⊕ lt f) / lc f" t f "lt f"] lc_not_0[OF ‹f ≠ 0›] show ?thesis unfolding q_def lc_def by simp qed lemma red_single_higher: assumes "red_single p q f t" shows "higher q (t ⊕ lt f) = higher p (t ⊕ lt f)" using assms unfolding higher_eq_iff red_single_def proof (intro allI, intro impI) fix u assume a: "t ⊕ lt f ≺⇩t u" and "f ≠ 0 ∧ lookup p (t ⊕ lt f) ≠ 0 ∧ q = p - monom_mult (lookup p (t ⊕ lt f) / lc f) t f" hence "f ≠ 0" and "lookup p (t ⊕ lt f) ≠ 0" and q_def: "q = p - monom_mult (lookup p (t ⊕ lt f) / lc f) t f" by simp_all from ‹lookup p (t ⊕ lt f) ≠ 0› lc_not_0[OF ‹f ≠ 0›] have c_not_0: "lookup p (t ⊕ lt f) / lc f ≠ 0" by (simp add: field_simps) from q_def lookup_minus[of p "monom_mult (lookup p (t ⊕ lt f) / lc f) t f"] have q_lookup: "⋀s. lookup q s = lookup p s - lookup (monom_mult (lookup p (t ⊕ lt f) / lc f) t f) s" by simp from a lt_monom_mult[OF c_not_0 ‹f ≠ 0›, of t] have "¬ u ≼⇩t lt (monom_mult (lookup p (t ⊕ lt f) / lc f) t f)" by simp with lt_max[of "monom_mult (lookup p (t ⊕ lt f) / lc f) t f" u] have "lookup (monom_mult (lookup p (t ⊕ lt f) / lc f) t f) u = 0" by auto thus "lookup q u = lookup p u" using q_lookup[of u] by simp qed lemma red_single_ord: assumes "red_single p q f t" shows "q ≺⇩p p" unfolding ord_strict_higher proof (intro exI, intro conjI) from red_single_lookup[OF assms] show "lookup q (t ⊕ lt f) = 0" . next from assms show "lookup p (t ⊕ lt f) ≠ 0" unfolding red_single_def by simp next from red_single_higher[OF assms] show "higher q (t ⊕ lt f) = higher p (t ⊕ lt f)" . qed lemma red_single_nonzero1: assumes "red_single p q f t" shows "p ≠ 0" proof assume "p = 0" from this red_single_ord[OF assms] ord_p_zero_min[of q] show False by simp qed lemma red_single_nonzero2: assumes "red_single p q f t" shows "f ≠ 0" proof assume "f = 0" from assms monom_mult_zero_right have "f ≠ 0" by (simp add: red_single_def) from this ‹f = 0› show False by simp qed lemma red_single_self: assumes "p ≠ 0" shows "red_single p 0 p 0" proof - from lc_not_0[OF assms] have lc: "lc p ≠ 0" . show ?thesis unfolding red_single_def proof (intro conjI) show "p ≠ 0" by fact next from lc show "lookup p (0 ⊕ lt p) ≠ 0" unfolding lc_def by (simp add: term_simps) next from lc have "(lookup p (0 ⊕ lt p)) / lc p = 1" unfolding lc_def by (simp add: term_simps) from this monom_mult_one_left[of p] show "0 = p - monom_mult (lookup p (0 ⊕ lt p) / lc p) 0 p" by simp qed qed lemma red_single_trans: assumes "red_single p p0 f t" and "lt g adds⇩t lt f" and "g ≠ 0" obtains p1 where "red_single p p1 g (t + (lp f - lp g))" proof - let ?s = "t + (lp f - lp g)" let ?p = "p - monom_mult (lookup p (?s ⊕ lt g) / lc g) ?s g" have "red_single p ?p g ?s" unfolding red_single_def proof (intro conjI) from assms(2) have eq: "?s ⊕ lt g = t ⊕ lt f" using adds_term_alt splus_assoc by (auto simp: term_simps) from ‹red_single p p0 f t› have "lookup p (t ⊕ lt f) ≠ 0" unfolding red_single_def by simp thus "lookup p (?s ⊕ lt g) ≠ 0" by (simp add: eq) qed (fact, fact refl) thus ?thesis .. qed lemma red_nonzero: assumes "red F p q" shows "p ≠ 0" proof - from red_setE[OF assms] obtain f t where "red_single p q f t" . show ?thesis by (rule red_single_nonzero1, fact) qed lemma red_self: assumes "p ≠ 0" shows "red {p} p 0" unfolding red_singleton proof from red_single_self[OF assms] show "red_single p 0 p 0" . qed lemma red_ord: assumes "red F p q" shows "q ≺⇩p p" proof - from red_setE[OF assms] obtain f and t where "red_single p q f t" . from red_single_ord[OF this] show "q ≺⇩p p" . qed lemma red_indI1: assumes "f ∈ F" and "f ≠ 0" and "p ≠ 0" and adds: "lt f adds⇩t lt p" shows "red F p (p - monom_mult (lc p / lc f) (lp p - lp f) f)" proof (intro red_setI[OF ‹f ∈ F›]) let ?s = "lp p - lp f" have c: "lookup p (?s ⊕ lt f) = lc p" unfolding lc_def by (metis add_diff_cancel_right' adds adds_termE pp_of_term_splus) show "red_single p (p - monom_mult (lc p / lc f) ?s f) f ?s" unfolding red_single_def proof (intro conjI, fact) from c lc_not_0[OF ‹p ≠ 0›] show "lookup p (?s ⊕ lt f) ≠ 0" by simp next from c show "p - monom_mult (lc p / lc f) ?s f = p - monom_mult (lookup p (?s ⊕ lt f) / lc f) ?s f" by simp qed qed lemma red_indI2: assumes "p ≠ 0" and r: "red F (tail p) q" shows "red F p (q + monomial (lc p) (lt p))" proof - from red_setE[OF r] obtain f t where "f ∈ F" and rs: "red_single (tail p) q f t" by auto from rs have "f ≠ 0" and ct: "lookup (tail p) (t ⊕ lt f) ≠ 0" and q: "q = tail p - monom_mult (lookup (tail p) (t ⊕ lt f) / lc f) t f" unfolding red_single_def by simp_all from ct lookup_tail[of p "t ⊕ lt f"] have "t ⊕ lt f ≺⇩t lt p" by (auto split: if_splits) hence c: "lookup (tail p) (t ⊕ lt f) = lookup p (t ⊕ lt f)" using lookup_tail[of p] by simp show ?thesis proof (intro red_setI[OF ‹f ∈ F›]) show "red_single p (q + Poly_Mapping.single (lt p) (lc p)) f t" unfolding red_single_def proof (intro conjI, fact) from ct c show "lookup p (t ⊕ lt f) ≠ 0" by simp next from q have "q + monomial (lc p) (lt p) = (monomial (lc p) (lt p) + tail p) - monom_mult (lookup (tail p) (t ⊕ lt f) / lc f) t f" by simp also have "… = p - monom_mult (lookup (tail p) (t ⊕ lt f) / lc f) t f" using leading_monomial_tail[of p] by auto finally show "q + monomial (lc p) (lt p) = p - monom_mult (lookup p (t ⊕ lt f) / lc f) t f" by (simp only: c) qed qed qed lemma red_indE: assumes "red F p q" shows "(∃f∈F. f ≠ 0 ∧ lt f adds⇩t lt p ∧ (q = p - monom_mult (lc p / lc f) (lp p - lp f) f)) ∨ red F (tail p) (q - monomial (lc p) (lt p))" proof - from red_nonzero[OF assms] have "p ≠ 0" . from red_setE[OF assms] obtain f t where "f ∈ F" and rs: "red_single p q f t" by auto from rs have "f ≠ 0" and cn0: "lookup p (t ⊕ lt f) ≠ 0" and q: "q = p - monom_mult ((lookup p (t ⊕ lt f)) / lc f) t f" unfolding red_single_def by simp_all show ?thesis proof (cases "lt p = t ⊕ lt f") case True hence "lt f adds⇩t lt p" by (simp add: term_simps) from True have eq1: "lp p - lp f = t" by (simp add: term_simps) from True have eq2: "lc p = lookup p (t ⊕ lt f)" unfolding lc_def by simp show ?thesis proof (intro disjI1, rule bexI[of _ f], intro conjI, fact+) from q eq1 eq2 show "q = p - monom_mult (lc p / lc f) (lp p - lp f) f" by simp qed (fact) next case False from this lookup_tail_2[of p "t ⊕ lt f"] have ct: "lookup (tail p) (t ⊕ lt f) = lookup p (t ⊕ lt f)" by simp show ?thesis proof (intro disjI2, intro red_setI[of f], fact) show "red_single (tail p) (q - monomial (lc p) (lt p)) f t" unfolding red_single_def proof (intro conjI, fact) from cn0 ct show "lookup (tail p) (t ⊕ lt f) ≠ 0" by simp next from leading_monomial_tail[of p] have "p - monomial (lc p) (lt p) = (monomial (lc p) (lt p) + tail p) - monomial (lc p) (lt p)" by simp also have "… = tail p" by simp finally have eq: "p - monomial (lc p) (lt p) = tail p" . from q have "q - monomial (lc p) (lt p) = (p - monomial (lc p) (lt p)) - monom_mult ((lookup p (t ⊕ lt f)) / lc f) t f" by simp also from eq have "… = tail p - monom_mult ((lookup p (t ⊕ lt f)) / lc f) t f" by simp finally show "q - monomial (lc p) (lt p) = tail p - monom_mult (lookup (tail p) (t ⊕ lt f) / lc f) t f" using ct by simp qed qed qed qed lemma is_redI: assumes "red F a b" shows "is_red F a" unfolding is_red_def relation.is_final_def by (simp, intro exI[of _ b], fact) lemma is_redE: assumes "is_red F a" obtains b where "red F a b" using assms unfolding is_red_def relation.is_final_def proof simp assume r: "⋀b. red F a b ⟹ thesis" and b: "∃x. red F a x" from b obtain b where "red F a b" .. show thesis by (rule r[of b], fact) qed lemma is_red_alt: shows "is_red F a ⟷ (∃b. red F a b)" proof assume "is_red F a" from is_redE[OF this] obtain b where "red F a b" . show "∃b. red F a b" by (intro exI[of _ b], fact) next assume "∃b. red F a b" from this obtain b where "red F a b" .. show "is_red F a" by (rule is_redI, fact) qed lemma is_red_singletonI: assumes "is_red F q" obtains p where "p ∈ F" and "is_red {p} q" proof - from assms obtain q0 where "red F q q0" unfolding is_red_alt .. from this red_def[of F q q0] obtain p where "p ∈ F" and t: "∃t. red_single q q0 p t" by auto have "is_red {p} q" unfolding is_red_alt proof from red_singleton[of p q q0] t show "red {p} q q0" by simp qed from ‹p ∈ F› this show ?thesis .. qed lemma is_red_singletonD: assumes "is_red {p} q" and "p ∈ F" shows "is_red F q" proof - from assms(1) obtain q0 where "red {p} q q0" unfolding is_red_alt .. from red_singleton[of p q q0] this have "∃t. red_single q q0 p t" .. from this obtain t where "red_single q q0 p t" .. show ?thesis unfolding is_red_alt by (intro exI[of _ q0], intro red_setI[OF assms(2), of q q0 t], fact) qed lemma is_red_singleton_trans: assumes "is_red {f} p" and "lt g adds⇩t lt f" and "g ≠ 0" shows "is_red {g} p" proof - from ‹is_red {f} p› obtain q where "red {f} p q" unfolding is_red_alt .. from this red_singleton[of f p q] obtain t where "red_single p q f t" by auto from red_single_trans[OF this assms(2, 3)] obtain q0 where "red_single p q0 g (t + (lp f - lp g))" . show ?thesis proof (rule is_redI[of "{g}" p q0]) show "red {g} p q0" unfolding red_def by (intro bexI[of _ g], intro exI[of _ "t + (lp f - lp g)"], fact, simp) qed qed lemma is_red_singleton_not_0: assumes "is_red {f} p" shows "f ≠ 0" using assms unfolding is_red_alt proof fix q assume "red {f} p q" from this red_singleton[of f p q] obtain t where "red_single p q f t" by auto thus ?thesis unfolding red_single_def .. qed lemma irred_0: shows "¬ is_red F 0" proof (rule, rule is_redE) fix b assume "red F 0 b" from ord_p_zero_min[of b] red_ord[OF this] show False by simp qed lemma is_red_indI1: assumes "f ∈ F" and "f ≠ 0" and "p ≠ 0" and "lt f adds⇩t lt p" shows "is_red F p" by (intro is_redI, rule red_indI1[OF assms]) lemma is_red_indI2: assumes "p ≠ 0" and "is_red F (tail p)" shows "is_red F p" proof - from is_redE[OF ‹is_red F (tail p)›] obtain q where "red F (tail p) q" . show ?thesis by (intro is_redI, rule red_indI2[OF ‹p ≠ 0›], fact) qed lemma is_red_indE: assumes "is_red F p" shows "(∃f∈F. f ≠ 0 ∧ lt f adds⇩t lt p) ∨ is_red F (tail p)" proof - from is_redE[OF assms] obtain q where "red F p q" . from red_indE[OF this] show ?thesis proof assume "∃f∈F. f ≠ 0 ∧ lt f adds⇩t lt p ∧ q = p - monom_mult (lc p / lc f) (lp p - lp f) f" from this obtain f where "f ∈ F" and "f ≠ 0" and "lt f adds⇩t lt p" by auto show ?thesis by (intro disjI1, rule bexI[of _ f], intro conjI, fact+) next assume "red F (tail p) (q - monomial (lc p) (lt p))" show ?thesis by (intro disjI2, intro is_redI, fact) qed qed lemma rtrancl_0: assumes "(red F)⇧*⇧* 0 x" shows "x = 0" proof - from irred_0[of F] have "relation.is_final (red F) 0" unfolding is_red_def by simp from relation.rtrancl_is_final[OF ‹(red F)⇧*⇧* 0 x› this] show ?thesis by simp qed lemma red_rtrancl_ord: assumes "(red F)⇧*⇧* p q" shows "q ≼⇩p p" using assms proof induct case base show ?case .. next case (step y z) from step(2) have "z ≺⇩p y" by (rule red_ord) hence "z ≼⇩p y" by simp also note step(3) finally show ?case . qed lemma components_red_subset: assumes "red F p q" shows "component_of_term ` keys q ⊆ component_of_term ` keys p ∪ component_of_term ` Keys F" proof - from assms obtain f t where "f ∈ F" and "red_single p q f t" by (rule red_setE) from this(2) have q: "q = p - monom_mult ((lookup p (t ⊕ lt f)) / lc f) t f" by (simp add: red_single_def) have "component_of_term ` keys q ⊆ component_of_term ` (keys p ∪ keys (monom_mult ((lookup p (t ⊕ lt f)) / lc f) t f))" by (rule image_mono, simp add: q keys_minus) also have "... ⊆ component_of_term ` keys p ∪ component_of_term ` Keys F" proof (simp add: image_Un, rule) fix k assume "k ∈ component_of_term ` keys (monom_mult (lookup p (t ⊕ lt f) / lc f) t f)" then obtain v where "v ∈ keys (monom_mult (lookup p (t ⊕ lt f) / lc f) t f)" and "k = component_of_term v" .. from this(1) keys_monom_mult_subset have "v ∈ (⊕) t ` keys f" .. then obtain u where "u ∈ keys f" and "v = t ⊕ u" .. have "k = component_of_term u" by (simp add: ‹k = component_of_term v› ‹v = t ⊕ u› term_simps) with ‹u ∈ keys f› have "k ∈ component_of_term ` keys f" by fastforce also have "... ⊆ component_of_term ` Keys F" by (rule image_mono, rule keys_subset_Keys, fact) finally show "k ∈ component_of_term ` keys p ∪ component_of_term ` Keys F" by simp qed finally show ?thesis . qed corollary components_red_rtrancl_subset: assumes "(red F)⇧*⇧* p q" shows "component_of_term ` keys q ⊆ component_of_term ` keys p ∪ component_of_term ` Keys F" using assms proof (induct) case base show ?case by simp next case (step q r) from step(2) have "component_of_term ` keys r ⊆ component_of_term ` keys q ∪ component_of_term ` Keys F" by (rule components_red_subset) also from step(3) have "... ⊆ component_of_term ` keys p ∪ component_of_term ` Keys F" by blast finally show ?case . qed subsection ‹Reducibility and Addition \& Multiplication› lemma red_single_monom_mult: assumes "red_single p q f t" and "c ≠ 0" shows "red_single (monom_mult c s p) (monom_mult c s q) f (s + t)" proof - from assms(1) have "f ≠ 0" and "lookup p (t ⊕ lt f) ≠ 0" and q_def: "q = p - monom_mult ((lookup p (t ⊕ lt f)) / lc f) t f" unfolding red_single_def by auto have assoc: "(s + t) ⊕ lt f = s ⊕ (t ⊕ lt f)" by (simp add: ac_simps) have g2: "lookup (monom_mult c s p) ((s + t) ⊕ lt f) ≠ 0" proof assume "lookup (monom_mult c s p) ((s + t) ⊕ lt f) = 0" hence "c * lookup p (t ⊕ lt f) = 0" using assoc by (simp add: lookup_monom_mult_plus) thus False using ‹c ≠ 0› ‹lookup p (t ⊕ lt f) ≠ 0› by simp qed have g3: "monom_mult c s q = (monom_mult c s p) - monom_mult ((lookup (monom_mult c s p) ((s + t) ⊕ lt f)) / lc f) (s + t) f" proof - from q_def monom_mult_dist_right_minus[of c s p] have "monom_mult c s q = monom_mult c s p - monom_mult c s (monom_mult (lookup p (t ⊕ lt f) / lc f) t f)" by simp also from monom_mult_assoc[of c s "lookup p (t ⊕ lt f) / lc f" t f] assoc have "monom_mult c s (monom_mult (lookup p (t ⊕ lt f) / lc f) t f) = monom_mult ((lookup (monom_mult c s p) ((s + t) ⊕ lt f)) / lc f) (s + t) f" by (simp add: lookup_monom_mult_plus) finally show ?thesis . qed from ‹f ≠ 0› g2 g3 show ?thesis unfolding red_single_def by auto qed lemma red_single_plus_1: assumes "red_single p q f t" and "t ⊕ lt f ∉ keys (p + r)" shows "red_single (q + r) (p + r) f t" proof - from assms have "f ≠ 0" and "lookup p (t ⊕ lt f) ≠ 0" and q: "q = p - monom_mult ((lookup p (t ⊕ lt f)) / lc f) t f" by (simp_all add: red_single_def) from assms(1) have cq_0: "lookup q (t ⊕ lt f) = 0" by (rule red_single_lookup) from assms(2) have "lookup (p + r) (t ⊕ lt f) = 0" by (simp add: in_keys_iff) with neg_eq_iff_add_eq_0[of "lookup p (t ⊕ lt f)" "lookup r (t ⊕ lt f)"] have cr: "lookup r (t ⊕ lt f) = - (lookup p (t ⊕ lt f))" by (simp add: lookup_add) hence cr_not_0: "lookup r (t ⊕ lt f) ≠ 0" using ‹lookup p (t ⊕ lt f) ≠ 0› by simp from ‹f ≠ 0› show ?thesis unfolding red_single_def proof (intro conjI) from cr_not_0 show "lookup (q + r) (t ⊕ lt f) ≠ 0" by (simp add: lookup_add cq_0) next from lc_not_0[OF ‹f ≠ 0›] have "monom_mult ((lookup (q + r) (t ⊕ lt f)) / lc f) t f = monom_mult ((lookup r (t ⊕ lt f)) / lc f) t f" by (simp add: field_simps lookup_add cq_0) thus "p + r = q + r - monom_mult (lookup (q + r) (t ⊕ lt f) / lc f) t f" by (simp add: cr q monom_mult_uminus_left) qed qed lemma red_single_plus_2: assumes "red_single p q f t" and "t ⊕ lt f ∉ keys (q + r)" shows "red_single (p + r) (q + r) f t" proof - from assms have "f ≠ 0" and cp: "lookup p (t ⊕ lt f) ≠ 0" and q: "q = p - monom_mult ((lookup p (t ⊕ lt f)) / lc f) t f" by (simp_all add: red_single_def) from assms(1) have cq_0: "lookup q (t ⊕ lt f) = 0" by (rule red_single_lookup) with assms(2) have cr_0: "lookup r (t ⊕ lt f) = 0" by (simp add: lookup_add in_keys_iff) from ‹f ≠ 0› show ?thesis unfolding red_single_def proof (intro conjI) from cp show "lookup (p + r) (t ⊕ lt f) ≠ 0" by (simp add: lookup_add cr_0) next show "q + r = p + r - monom_mult (lookup (p + r) (t ⊕ lt f) / lc f) t f" by (simp add: cr_0 q lookup_add) qed qed lemma red_single_plus_3: assumes "red_single p q f t" and "t ⊕ lt f ∈ keys (p + r)" and "t ⊕ lt f ∈ keys (q + r)" shows "∃s. red_single (p + r) s f t ∧ red_single (q + r) s f t" proof - let ?t = "t ⊕ lt f" from assms have "f ≠ 0" and "lookup p ?t ≠ 0" and q: "q = p - monom_mult ((lookup p ?t) / lc f) t f" by (simp_all add: red_single_def) from assms(2) have cpr: "lookup (p + r) ?t ≠ 0" by (simp add: in_keys_iff) from assms(3) have cqr: "lookup (q + r) ?t ≠ 0" by (simp add: in_keys_iff) from assms(1) have cq_0: "lookup q ?t = 0" by (rule red_single_lookup) let ?s = "(p + r) - monom_mult ((lookup (p + r) ?t) / lc f) t f" from ‹f ≠ 0› cpr have "red_single (p + r) ?s f t" by (simp add: red_single_def) moreover from ‹f ≠ 0› have "red_single (q + r) ?s f t" unfolding red_single_def proof (intro conjI) from cqr show "lookup (q + r) ?t ≠ 0" . next from lc_not_0[OF ‹f ≠ 0›] monom_mult_dist_left[of "(lookup p ?t) / lc f" "(lookup r ?t) / lc f" t f] have "monom_mult ((lookup (p + r) ?t) / lc f) t f = (monom_mult ((lookup p ?t) / lc f) t f) + (monom_mult ((lookup r ?t) / lc f) t f)" by (simp add: field_simps lookup_add) moreover from lc_not_0[OF ‹f ≠ 0›] monom_mult_dist_left[of "(lookup q ?t) / lc f" "(lookup r ?t) / lc f" t f] have "monom_mult ((lookup (q + r) ?t) / lc f) t f = monom_mult ((lookup r ?t) / lc f) t f" by (simp add: field_simps lookup_add cq_0) ultimately show "p + r - monom_mult (lookup (p + r) ?t / lc f) t f = q + r - monom_mult (lookup (q + r) ?t / lc f) t f" by (simp add: q) qed ultimately show ?thesis by auto qed lemma red_single_plus: assumes "red_single p q f t" shows "red_single (p + r) (q + r) f t ∨ red_single (q + r) (p + r) f t ∨ (∃s. red_single (p + r) s f t ∧ red_single (q + r) s f t)" (is "?A ∨ ?B ∨ ?C") proof (cases "t ⊕ lt f ∈ keys (p + r)") case True show ?thesis proof (cases "t ⊕ lt f ∈ keys (q + r)") case True with assms ‹t ⊕ lt f ∈ keys (p + r)› have ?C by (rule red_single_plus_3) thus ?thesis by simp next case False with assms have ?A by (rule red_single_plus_2) thus ?thesis .. qed next case False with assms have ?B by (rule red_single_plus_1) thus ?thesis by simp qed lemma red_single_diff: assumes "red_single (p - q) r f t" shows "red_single p (r + q) f t ∨ red_single q (p - r) f t ∨ (∃p' q'. red_single p p' f t ∧ red_single q q' f t ∧ r = p' - q')" (is "?A ∨ ?B ∨ ?C") proof - let ?s = "t ⊕ lt f" from assms have "f ≠ 0" and "lookup (p - q) ?s ≠ 0" and r: "r = p - q - monom_mult ((lookup (p - q) ?s) / lc f) t f" unfolding red_single_def by auto from this(2) have diff: "lookup p ?s ≠ lookup q ?s" by (simp add: lookup_minus) show ?thesis proof (cases "lookup p ?s = 0") case True with diff have "?s ∈ keys q" by (simp add: in_keys_iff) moreover have "lookup (p - q) ?s = - lookup q ?s" by (simp add: lookup_minus True) ultimately have ?B using ‹f ≠ 0› by (simp add: in_keys_iff red_single_def r monom_mult_uminus_left) thus ?thesis by simp next case False hence "?s ∈ keys p" by (simp add: in_keys_iff) show ?thesis proof (cases "lookup q ?s = 0") case True hence "lookup (p - q) ?s = lookup p ?s" by (simp add: lookup_minus) hence ?A using ‹f ≠ 0› ‹?s ∈ keys p› by (simp add: in_keys_iff red_single_def r monom_mult_uminus_left) thus ?thesis .. next case False hence "?s ∈ keys q" by (simp add: in_keys_iff) let ?p = "p - monom_mult ((lookup p ?s) / lc f) t f" let ?q = "q - monom_mult ((lookup q ?s) / lc f) t f" have ?C proof (intro exI conjI) from ‹f ≠ 0› ‹?s ∈ keys p› show "red_single p ?p f t" by (simp add: in_keys_iff red_single_def) next from ‹f ≠ 0› ‹?s ∈ keys q› show "red_single q ?q f t" by (simp add: in_keys_iff red_single_def) next from ‹f ≠ 0› have "lc f ≠ 0" by (rule lc_not_0) hence eq: "(lookup p ?s - lookup q ?s) / lc f = lookup p ?s / lc f - lookup q ?s / lc f" by (simp add: field_simps) show "r = ?p - ?q" by (simp add: r lookup_minus eq monom_mult_dist_left_minus) qed thus ?thesis by simp qed qed qed lemma red_monom_mult: assumes a: "red F p q" and "c ≠ 0" shows "red F (monom_mult c s p) (monom_mult c s q)" proof - from red_setE[OF a] obtain f and t where "f ∈ F" and rs: "red_single p q f t" by auto from red_single_monom_mult[OF rs ‹c ≠ 0›, of s] show ?thesis by (intro red_setI[OF ‹f ∈ F›]) qed lemma red_plus_keys_disjoint: assumes "red F p q" and "keys p ∩ keys r = {}" shows "red F (p + r) (q + r)" proof - from assms(1) obtain f t where "f ∈ F" and *: "red_single p q f t" by (rule red_setE) from this(2) have "red_single (p + r) (q + r) f t" proof (rule red_single_plus_2) from * have "lookup q (t ⊕ lt f) = 0" by (simp add: red_single_def lookup_minus lookup_monom_mult lc_def[symmetric] lc_not_0 term_simps) hence "t ⊕ lt f ∉ keys q" by (simp add: in_keys_iff) moreover have "t ⊕ lt f ∉ keys r" proof assume "t ⊕ lt f ∈ keys r" moreover from * have "t ⊕ lt f ∈ keys p" by (simp add: in_keys_iff red_single_def) ultimately have "t ⊕ lt f ∈ keys p ∩ keys r" by simp with assms(2) show False by simp qed ultimately have "t ⊕ lt f ∉ keys q ∪ keys r" by simp thus "t ⊕ lt f ∉ keys (q + r)" by (meson Poly_Mapping.keys_add subsetD) qed with ‹f ∈ F› show ?thesis by (rule red_setI) qed lemma red_plus: assumes "red F p q" obtains s where "(red F)⇧*⇧* (p + r) s" and "(red F)⇧*⇧* (q + r) s" proof - from red_setE[OF assms] obtain f and t where "f ∈ F" and rs: "red_single p q f t" by auto from red_single_plus[OF rs, of r] show ?thesis proof assume c1: "red_single (p + r) (q + r) f t" show ?thesis proof from c1 show "(red F)⇧*⇧* (p + r) (q + r)" by (intro r_into_rtranclp, intro red_setI[OF ‹f ∈ F›]) next show "(red F)⇧*⇧* (q + r) (q + r)" .. qed next assume "red_single (q + r) (p + r) f t ∨ (∃s. red_single (p + r) s f t ∧ red_single (q + r) s f t)" thus ?thesis proof assume c2: "red_single (q + r) (p + r) f t" show ?thesis proof show "(red F)⇧*⇧* (p + r) (p + r)" .. next from c2 show "(red F)⇧*⇧* (q + r) (p + r)" by (intro r_into_rtranclp, intro red_setI[OF ‹f ∈ F›]) qed next assume "∃s. red_single (p + r) s f t ∧ red_single (q + r) s f t" then obtain s where s1: "red_single (p + r) s f t" and s2: "red_single (q + r) s f t" by auto show ?thesis proof from s1 show "(red F)⇧*⇧* (p + r) s" by (intro r_into_rtranclp, intro red_setI[OF ‹f ∈ F›]) next from s2 show "(red F)⇧*⇧* (q + r) s" by (intro r_into_rtranclp, intro red_setI[OF ‹f ∈ F›]) qed qed qed qed corollary red_plus_cs: assumes "red F p q" shows "relation.cs (red F) (p + r) (q + r)" unfolding relation.cs_def proof - from assms obtain s where "(red F)⇧*⇧* (p + r) s" and "(red F)⇧*⇧* (q + r) s" by (rule red_plus) show "∃s. (red F)⇧*⇧* (p + r) s ∧ (red F)⇧*⇧* (q + r) s" by (intro exI, intro conjI, fact, fact) qed lemma red_uminus: assumes "red F p q" shows "red F (-p) (-q)" using red_monom_mult[OF assms, of "-1" 0] by (simp add: uminus_monom_mult) lemma red_diff: assumes "red F (p - q) r" obtains p' q' where "(red F)⇧*⇧* p p'" and "(red F)⇧*⇧* q q'" and "r = p' - q'" proof - from assms obtain f t where "f ∈ F" and "red_single (p - q) r f t" by (rule red_setE) from red_single_diff[OF this(2)] show ?thesis proof (elim disjE) assume "red_single p (r + q) f t" with ‹f ∈ F› have *: "red F p (r + q)" by (rule red_setI) show ?thesis proof from * show "(red F)⇧*⇧* p (r + q)" .. next show "(red F)⇧*⇧* q q" .. qed simp next assume "red_single q (p - r) f t" with ‹f ∈ F› have *: "red F q (p - r)" by (rule red_setI) show ?thesis proof show "(red F)⇧*⇧* p p" .. next from * show "(red F)⇧*⇧* q (p - r)" .. qed simp next assume "∃p' q'. red_single p p' f t ∧ red_single q q' f t ∧ r = p' - q'" then obtain p' q' where 1: "red_single p p' f t" and 2: "red_single q q' f t" and "r = p' - q'" by blast from ‹f ∈ F› 2 have "red F q q'" by (rule red_setI) from ‹f ∈ F› 1 have "red F p p'" by (rule red_setI) hence "(red F)⇧*⇧* p p'" .. moreover from ‹red F q q'› have "(red F)⇧*⇧* q q'" .. moreover note ‹r = p' - q'› ultimately show ?thesis .. qed qed lemma red_diff_rtrancl': assumes "(red F)⇧*⇧* (p - q) r" obtains p' q' where "(red F)⇧*⇧* p p'" and "(red F)⇧*⇧* q q'" and "r = p' - q'" using assms proof (induct arbitrary: thesis rule: rtranclp_induct) case base show ?case by (rule base, fact rtrancl_refl[to_pred], fact rtrancl_refl[to_pred], fact refl) next case (step y z) obtain p1 q1 where p1: "(red F)⇧*⇧* p p1" and q1: "(red F)⇧*⇧* q q1" and y: "y = p1 - q1" by (rule step(3)) from step(2) obtain p' q' where p': "(red F)⇧*⇧* p1 p'" and q': "(red F)⇧*⇧* q1 q'" and z: "z = p' - q'" unfolding y by (rule red_diff) show ?case proof (rule step(4)) from p1 p' show "(red F)⇧*⇧* p p'" by simp next from q1 q' show "(red F)⇧*⇧* q q'" by simp qed fact qed lemma red_diff_rtrancl: assumes "(red F)⇧*⇧* (p - q) 0" obtains s where "(red F)⇧*⇧* p s" and "(red F)⇧*⇧* q s" proof - from assms obtain p' q' where p': "(red F)⇧*⇧* p p'" and q': "(red F)⇧*⇧* q q'" and "0 = p' - q'" by (rule red_diff_rtrancl') from this(3) have "q' = p'" by simp from p' q' show ?thesis unfolding ‹q' = p'› .. qed corollary red_diff_rtrancl_cs: assumes "(red F)⇧*⇧* (p - q) 0" shows "relation.cs (red F) p q" unfolding relation.cs_def proof - from assms obtain s where "(red F)⇧*⇧* p s" and "(red F)⇧*⇧* q s" by (rule red_diff_rtrancl) show "∃s. (red F)⇧*⇧* p s ∧ (red F)⇧*⇧* q s" by (intro exI, intro conjI, fact, fact) qed subsection ‹Confluence of Reducibility› lemma confluent_distinct_aux: assumes r1: "red_single p q1 f1 t1" and r2: "red_single p q2 f2 t2" and "t1 ⊕ lt f1 ≺⇩t t2 ⊕ lt f2" and "f1 ∈ F" and "f2 ∈ F" obtains s where "(red F)⇧*⇧* q1 s" and "(red F)⇧*⇧* q2 s" proof - from r1 have "f1 ≠ 0" and c1: "lookup p (t1 ⊕ lt f1) ≠ 0" and q1_def: "q1 = p - monom_mult (lookup p (t1 ⊕ lt f1) / lc f1) t1 f1" unfolding red_single_def by auto from r2 have "f2 ≠ 0" and c2: "lookup p (t2 ⊕ lt f2) ≠ 0" and q2_def: "q2 = p - monom_mult (lookup p (t2 ⊕ lt f2) / lc f2) t2 f2" unfolding red_single_def by auto from ‹t1 ⊕ lt f1 ≺⇩t t2 ⊕ lt f2› have "lookup (monom_mult (lookup p (t1 ⊕ lt f1) / lc f1) t1 f1) (t2 ⊕ lt f2) = 0" by (simp add: lookup_monom_mult_eq_zero) from lookup_minus[of p _ "t2 ⊕ lt f2"] this have c: "lookup q1 (t2 ⊕ lt f2) = lookup p (t2 ⊕ lt f2)" unfolding q1_def by simp define q3 where "q3 ≡ q1 - monom_mult ((lookup q1 (t2 ⊕ lt f2)) / lc f2) t2 f2" have "red_single q1 q3 f2 t2" unfolding red_single_def proof (rule, fact, rule) from c c2 show "lookup q1 (t2 ⊕ lt f2) ≠ 0" by simp next show "q3 = q1 - monom_mult (lookup q1 (t2 ⊕ lt f2) / lc f2) t2 f2" unfolding q3_def .. qed hence "red F q1 q3" by (intro red_setI[OF ‹f2 ∈ F›]) hence q1q3: "(red F)⇧*⇧* q1 q3" by (intro r_into_rtranclp) from r1 have "red F p q1" by (intro red_setI[OF ‹f1 ∈ F›]) from red_plus[OF this, of "- monom_mult ((lookup p (t2 ⊕ lt f2)) / lc f2) t2 f2"] obtain s where r3: "(red F)⇧*⇧* (p - monom_mult (lookup p (t2 ⊕ lt f2) / lc f2) t2 f2) s" and r4: "(red F)⇧*⇧* (q1 - monom_mult (lookup p (t2 ⊕ lt f2) / lc f2) t2 f2) s" by auto from r3 have q2s: "(red F)⇧*⇧* q2 s" unfolding q2_def by simp from r4 c have q3s: "(red F)⇧*⇧* q3 s" unfolding q3_def by simp show ?thesis proof from rtranclp_trans[OF q1q3 q3s] show "(red F)⇧*⇧* q1 s" . next from q2s show "(red F)⇧*⇧* q2 s" . qed qed lemma confluent_distinct: assumes r1: "red_single p q1 f1 t1" and r2: "red_single p q2 f2 t2" and ne: "t1 ⊕ lt f1 ≠ t2 ⊕ lt f2" and "f1 ∈ F" and "f2 ∈ F" obtains s where "(red F)⇧*⇧* q1 s" and "(red F)⇧*⇧* q2 s" proof - from ne have "t1 ⊕ lt f1 ≺⇩t t2 ⊕ lt f2 ∨ t2 ⊕ lt f2 ≺⇩t t1 ⊕ lt f1" by auto thus ?thesis proof assume a1: "t1 ⊕ lt f1 ≺⇩t t2 ⊕ lt f2" from confluent_distinct_aux[OF r1 r2 a1 ‹f1 ∈ F› ‹f2 ∈ F›] obtain s where "(red F)⇧*⇧* q1 s" and "(red F)⇧*⇧* q2 s" . thus ?thesis .. next assume a2: "t2 ⊕ lt f2 ≺⇩t t1 ⊕ lt f1" from confluent_distinct_aux[OF r2 r1 a2 ‹f2 ∈ F› ‹f1 ∈ F›] obtain s where "(red F)⇧*⇧* q1 s" and "(red F)⇧*⇧* q2 s" . thus ?thesis .. qed qed corollary confluent_same: assumes r1: "red_single p q1 f t1" and r2: "red_single p q2 f t2" and "f ∈ F" obtains s where "(red F)⇧*⇧* q1 s" and "(red F)⇧*⇧* q2 s" proof (cases "t1 = t2") case True with r1 r2 have "q1 = q2" by (simp add: red_single_def) show ?thesis proof show "(red F)⇧*⇧* q1 q2" unfolding ‹q1 = q2› .. next show "(red F)⇧*⇧* q2 q2" .. qed next case False hence "t1 ⊕ lt f ≠ t2 ⊕ lt f" by (simp add: term_simps) from r1 r2 this ‹f ∈ F› ‹f ∈ F› obtain s where "(red F)⇧*⇧* q1 s" and "(red F)⇧*⇧* q2 s" by (rule confluent_distinct) thus ?thesis .. qed subsection ‹Reducibility and Module Membership› lemma srtc_in_pmdl: assumes "relation.srtc (red F) p q" shows "p - q ∈ pmdl F" using assms unfolding relation.srtc_def proof (induct rule: rtranclp.induct) fix p show "p - p ∈ pmdl F" by (simp add: pmdl.span_zero) next fix p r q assume pr_in: "p - r ∈ pmdl F" and red: "red F r q ∨ red F q r" from red obtain f c t where "f ∈ F" and "q = r - monom_mult c t f" proof assume "red F r q" from red_setE[OF this] obtain f t where "f ∈ F" and "red_single r q f t" . hence "q = r - monom_mult (lookup r (t ⊕ lt f) / lc f) t f" by (simp add: red_single_def) show thesis by (rule, fact, fact) next assume "red F q r" from red_setE[OF this] obtain f t where "f ∈ F" and "red_single q r f t" . hence "r = q - monom_mult (lookup q (t ⊕ lt f) / lc f) t f" by (simp add: red_single_def) hence "q = r + monom_mult (lookup q (t ⊕ lt f) / lc f) t f" by simp hence "q = r - monom_mult (-(lookup q (t ⊕ lt f) / lc f)) t f" using monom_mult_uminus_left[of _ t f] by simp show thesis by (rule, fact, fact) qed hence eq: "p - q = (p - r) + monom_mult c t f" by simp show "p - q ∈ pmdl F" unfolding eq by (rule pmdl.span_add, fact, rule monom_mult_in_pmdl, fact) qed lemma in_pmdl_srtc: assumes "p ∈ pmdl F" shows "relation.srtc (red F) p 0" using assms proof (induct p rule: pmdl_induct) show "relation.srtc (red F) 0 0" unfolding relation.srtc_def .. next fix a f c t assume a_in: "a ∈ pmdl F" and IH: "relation.srtc (red F) a 0" and "f ∈ F" show "relation.srtc (red F) (a + monom_mult c t f) 0" proof (cases "c = 0") assume "c = 0" hence "a + monom_mult c t f = a" by simp thus ?thesis using IH by simp next assume "c ≠ 0" show ?thesis proof (cases "f = 0") assume "f = 0" hence "a + monom_mult c t f = a" by simp thus ?thesis using IH by simp next assume "f ≠ 0" from lc_not_0[OF this] have "lc f ≠ 0" . have "red F (monom_mult c t f) 0" proof (intro red_setI[OF ‹f ∈ F›]) from lookup_monom_mult_plus[of c t f "lt f"] have eq: "lookup (monom_mult c t f) (t ⊕ lt f) = c * lc f" unfolding lc_def . show "red_single (monom_mult c t f) 0 f t" unfolding red_single_def eq proof (intro conjI, fact) from ‹c ≠ 0› ‹lc f ≠ 0› show "c * lc f ≠ 0" by simp next from ‹lc f ≠ 0› show "0 = monom_mult c t f - monom_mult (c * lc f / lc f) t f" by simp qed qed from red_plus[OF this, of a] obtain s where s1: "(red F)⇧*⇧* (monom_mult c t f + a) s" and s2: "(red F)⇧*⇧* (0 + a) s" . have "relation.cs (red F) (a + monom_mult c t f) a" unfolding relation.cs_def proof (intro exI[of _ s], intro conjI) from s1 show "(red F)⇧*⇧* (a + monom_mult c t f) s" by (simp only: add.commute) next from s2 show "(red F)⇧*⇧* a s" by simp qed from relation.srtc_transitive[OF relation.cs_implies_srtc[OF this] IH] show ?thesis . qed qed qed lemma red_rtranclp_diff_in_pmdl: assumes "(red F)⇧*⇧* p q" shows "p - q ∈ pmdl F" proof - from assms have "relation.srtc (red F) p q" by (simp add: r_into_rtranclp relation.rtc_implies_srtc) thus ?thesis by (rule srtc_in_pmdl) qed corollary red_diff_in_pmdl: assumes "red F p q" shows "p - q ∈ pmdl F" by (rule red_rtranclp_diff_in_pmdl, rule r_into_rtranclp, fact) corollary red_rtranclp_0_in_pmdl: assumes "(red F)⇧*⇧* p 0" shows "p ∈ pmdl F" using assms red_rtranclp_diff_in_pmdl by fastforce lemma pmdl_closed_red: assumes "pmdl B ⊆ pmdl A" and "p ∈ pmdl A" and "red B p q" shows "q ∈ pmdl A" proof - have "q - p ∈ pmdl A" proof have "p - q ∈ pmdl B" by (rule red_diff_in_pmdl, fact) hence "- (p - q) ∈ pmdl B" by (rule pmdl.span_neg) thus "q - p ∈ pmdl B" by simp qed fact from pmdl.span_add[OF this ‹p ∈ pmdl A›] show ?thesis by simp qed subsection ‹More Properties of @{const red}, @{const red_single} and @{const is_red}› lemma red_rtrancl_mult: assumes "(red F)⇧*⇧* p q" shows "(red F)⇧*⇧* (monom_mult c t p) (monom_mult c t q)" proof (cases "c = 0") case True have "(red F)⇧*⇧* 0 0" by simp thus ?thesis by (simp only: True monom_mult_zero_left) next case False from assms show ?thesis proof (induct rule: rtranclp_induct) show "(red F)⇧*⇧* (monom_mult c t p) (monom_mult c t p)" by simp next fix q0 q assume "(red F)⇧*⇧* p q0" and "red F q0 q" and "(red F)⇧*⇧* (monom_mult c t p) (monom_mult c t q0)" show "(red F)⇧*⇧* (monom_mult c t p) (monom_mult c t q)" proof (rule rtranclp.intros(2)[OF ‹(red F)⇧*⇧* (monom_mult c t p) (monom_mult c t q0)›]) from red_monom_mult[OF ‹red F q0 q› False, of t] show "red F (monom_mult c t q0) (monom_mult c t q)" . qed qed qed corollary red_rtrancl_uminus: assumes "(red F)⇧*⇧* p q" shows "(red F)⇧*⇧* (-p) (-q)" using red_rtrancl_mult[OF assms, of "-1" 0] by (simp add: uminus_monom_mult) lemma red_rtrancl_diff_induct [consumes 1, case_names base step]: assumes a: "(red F)⇧*⇧* (p - q) r" and cases: "P p p" "!!y z. [| (red F)⇧*⇧* (p - q) z; red F z y; P p (q + z)|] ==> P p (q + y)" shows "P p (q + r)" using a proof (induct rule: rtranclp_induct) from cases(1) show "P p (q + (p - q))" by simp next fix y z assume "(red F)⇧*⇧* (p - q) z" "red F z y" "P p (q + z)" thus "P p (q + y)" using cases(2) by simp qed lemma red_rtrancl_diff_0_induct [consumes 1, case_names base step]: assumes a: "(red F)⇧*⇧* (p - q) 0" and base: "P p p" and ind: "⋀y z. [| (red F)⇧*⇧* (p - q) y; red F y z; P p (y + q)|] ==> P p (z + q)" shows "P p q" proof - from ind red_rtrancl_diff_induct[of F p q 0 P, OF a base] have "P p (0 + q)" by (simp add: ac_simps) thus ?thesis by simp qed lemma is_red_union: "is_red (A ∪ B) p ⟷ (is_red A p ∨ is_red B p)" unfolding is_red_alt red_union by auto lemma red_single_0_lt: assumes "red_single f 0 h t" shows "lt f = t ⊕ lt h" proof - from red_single_nonzero1[OF assms] have "f ≠ 0" . { assume "h ≠ 0" and neq: "lookup f (t ⊕ lt h) ≠ 0" and eq: "f = monom_mult (lookup f (t ⊕ lt h) / lc h) t h" from lc_not_0[OF ‹h ≠ 0›] have "lc h ≠ 0" . with neq have "(lookup f (t ⊕ lt h) / lc h) ≠ 0" by simp from eq lt_monom_mult[OF this ‹h ≠ 0›, of t] have "lt f = t ⊕ lt h" by simp hence "lt f = t ⊕ lt h" by (simp add: ac_simps) } with assms show ?thesis unfolding red_single_def by auto qed lemma red_single_lt_distinct_lt: assumes rs: "red_single f g h t" and "g ≠ 0" and "lt g ≠ lt f" shows "lt f = t ⊕ lt h" proof - from red_single_nonzero1[OF rs] have "f ≠ 0" . from red_single_ord[OF rs] have "g ≼⇩p f" by simp from ord_p_lt[OF this] ‹lt g ≠ lt f› have "lt g ≺⇩t lt f" by simp { assume "h ≠ 0" and neq: "lookup f (t ⊕ lt h) ≠ 0" and eq: "f = g + monom_mult (lookup f (t ⊕ lt h) / lc h) t h" (is "f = g + ?R") from lc_not_0[OF ‹h ≠ 0›] have "lc h ≠ 0" . with neq have "(lookup f (t ⊕ lt h) / lc h) ≠ 0" (is "?c ≠ 0") by simp from eq lt_monom_mult[OF this ‹h ≠ 0›, of t] have ltR: "lt ?R = t ⊕ lt h" by simp from monom_mult_eq_zero_iff[of ?c t h] ‹?c ≠ 0› ‹h ≠ 0› have "?R ≠ 0" by auto from lt_plus_lessE[of g] eq ‹lt g ≺⇩t lt f› have "lt g ≺⇩t lt ?R" by auto from lt_plus_eqI[OF this] eq ltR have "lt f = t ⊕ lt h" by (simp add: ac_simps) } with assms show ?thesis unfolding red_single_def by auto qed lemma zero_reducibility_implies_lt_divisibility': assumes "(red F)⇧*⇧* f 0" and "f ≠ 0" shows "∃h∈F. h ≠ 0 ∧ (lt h adds⇩t lt f)" using assms proof (induct rule: converse_rtranclp_induct) case base then show ?case by simp next case (step f g) show ?case proof (cases "g = 0") case True with step.hyps have "red F f 0" by simp from red_setE[OF this] obtain h t where "h ∈ F" and rs: "red_single f 0 h t" by auto show ?thesis proof from red_single_0_lt[OF rs] have "lt h adds⇩t lt f" by (simp add: term_simps) also from rs have "h ≠ 0" by (simp add: red_single_def) ultimately show "h ≠ 0 ∧ lt h adds⇩t lt f" by simp qed (rule ‹h ∈ F›) next case False show ?thesis proof (cases "lt g = lt f") case True with False step.hyps show ?thesis by simp next case False from red_setE[OF ‹red F f g›] obtain h t where "h ∈ F" and rs: "red_single f g h t" by auto show ?thesis proof from red_single_lt_distinct_lt[OF rs ‹g ≠ 0› False] have "lt h adds⇩t lt f" by (simp add: term_simps) also from rs have "h ≠ 0" by (simp add: red_single_def) ultimately show "h ≠ 0 ∧ lt h adds⇩t lt f" by simp qed (rule ‹h ∈ F›) qed qed qed lemma zero_reducibility_implies_lt_divisibility: assumes "(red F)⇧*⇧* f 0" and "f ≠ 0" obtains h where "h ∈ F" and "h ≠ 0" and "lt h adds⇩t lt f" using zero_reducibility_implies_lt_divisibility'[OF assms] by auto lemma is_red_addsI: assumes "f ∈ F" and "f ≠ 0" and "v ∈ keys p" and "lt f adds⇩t v" shows "is_red F p" using assms proof (induction p rule: poly_mapping_tail_induct) case 0 from ‹v ∈ keys 0› show ?case by auto next case (tail p) from "tail.IH"[OF ‹f ∈ F› ‹f ≠ 0› _ ‹lt f adds⇩t v›] have imp: "v ∈ keys (tail p) ⟹ is_red F (tail p)" . show ?case proof (cases "v = lt p") case True show ?thesis proof (rule is_red_indI1[OF ‹f ∈ F› ‹f ≠ 0› ‹p ≠ 0›]) from ‹lt f adds⇩t v› True show "lt f adds⇩t lt p" by simp qed next case False with ‹v ∈ keys p› ‹p ≠ 0› have "v ∈ keys (tail p)" by (simp add: lookup_tail_2 in_keys_iff) from is_red_indI2[OF ‹p ≠ 0› imp[OF this]] show ?thesis . qed qed lemma is_red_addsE': assumes "is_red F p" shows "∃f∈F. ∃v∈keys p. f ≠ 0 ∧ lt f adds⇩t v" using assms proof (induction p rule: poly_mapping_tail_induct) case 0 with irred_0[of F] show ?case by simp next case (tail p) from is_red_indE[OF ‹is_red F p›] show ?case proof assume "∃f∈F. f ≠ 0 ∧ lt f adds⇩t lt p" then obtain f where "f ∈ F" and "f ≠ 0" and "lt f adds⇩t lt p" by auto show ?case proof show "∃v∈keys p. f ≠ 0 ∧ lt f adds⇩t v" proof (intro bexI, intro conjI) from ‹p ≠ 0› show "lt p ∈ keys p" by (metis in_keys_iff lc_def lc_not_0) qed (rule ‹f ≠ 0›, rule ‹lt f adds⇩t lt p›) qed (rule ‹f ∈ F›) next assume "is_red F (tail p)" from "tail.IH"[OF this] obtain f v where "f ∈ F" and "f ≠ 0" and v_in_keys_tail: "v ∈ keys (tail p)" and "lt f adds⇩t v" by auto from "tail.hyps" v_in_keys_tail have v_in_keys: "v ∈ keys p" by (metis lookup_tail in_keys_iff) show ?case proof show "∃v∈keys p. f ≠ 0 ∧ lt f adds⇩t v" by (intro bexI, intro conjI, rule ‹f ≠ 0›, rule ‹lt f adds⇩t v›, rule v_in_keys) qed (rule ‹f ∈ F›) qed qed lemma is_red_addsE: assumes "is_red F p" obtains f v where "f ∈ F" and "v ∈ keys p" and "f ≠ 0" and "lt f adds⇩t v" using is_red_addsE'[OF assms] by auto lemma is_red_adds_iff: shows "(is_red F p) ⟷ (∃f∈F. ∃v∈keys p. f ≠ 0 ∧ lt f adds⇩t v)" using is_red_addsE' is_red_addsI by auto lemma is_red_subset: assumes red: "is_red A p" and sub: "A ⊆ B" shows "is_red B p" proof - from red obtain f v where "f ∈ A" and "v ∈ keys p" and "f ≠ 0" and "lt f adds⇩t v" by (rule is_red_addsE) show ?thesis by (rule is_red_addsI, rule, fact+) qed lemma not_is_red_empty: "¬ is_red {} f" by (simp add: is_red_adds_iff) lemma red_single_mult_const: assumes "red_single p q f t" and "c ≠ 0" shows "red_single p q (monom_mult c 0 f) t" proof - let ?s = "t ⊕ lt f" let ?f = "monom_mult c 0 f" from assms(1) have "f ≠ 0" and "lookup p ?s ≠ 0" and "q = p - monom_mult ((lookup p ?s) / lc f) t f" by (simp_all add: red_single_def) from this(1) assms(2) have lt: "lt ?f = lt f" and lc: "lc ?f = c * lc f" by (simp add: lt_monom_mult term_simps, simp) show ?thesis unfolding red_single_def proof (intro conjI) from ‹f ≠ 0› assms(2) show "?f ≠ 0" by (simp add: monom_mult_eq_zero_iff) next from ‹lookup p ?s ≠ 0› show "lookup p (t ⊕ lt ?f) ≠ 0" by (simp add: lt) next show "q = p - monom_mult (lookup p (t ⊕ lt ?f) / lc ?f) t ?f" by (simp add: lt monom_mult_assoc lc assms(2), fact) qed qed lemma red_rtrancl_plus_higher: assumes "(red F)⇧*⇧* p q" and "⋀u v. u ∈ keys p ⟹ v ∈ keys r ⟹ u ≺⇩t v" shows "(red F)⇧*⇧* (p + r) (q + r)" using assms(1) proof induct case base show ?case .. next case (step y z) from step(1) have "y ≼⇩p p" by (rule red_rtrancl_ord) hence "lt y ≼⇩t lt p" by (rule ord_p_lt) from step(2) have "red F (y + r) (z + r)" proof (rule red_plus_keys_disjoint) show "keys y ∩ keys r = {}" proof (rule ccontr) assume "keys y ∩ keys r ≠ {}" then obtain v where "v ∈ keys y" and "v ∈ keys r" by auto from this(1) have "v ≼⇩t lt y" and "y ≠ 0" using lt_max by (auto simp: in_keys_iff) with ‹y ≼⇩p p› have "p ≠ 0" using ord_p_zero_min[of y] by auto hence "lt p ∈ keys p" by (rule lt_in_keys) from this ‹v ∈ keys r› have "lt p ≺⇩t v" by (rule assms(2)) with ‹lt y ≼⇩t lt p› have "lt y ≺⇩t v" by simp with ‹v ≼⇩t lt y› show False by simp qed qed with step(3) show ?case .. qed lemma red_mult_scalar_leading_monomial: "(red {f})⇧*⇧* (p ⊙ monomial (lc f) (lt f)) (- p ⊙ tail f)" proof (cases "f = 0") case True show ?thesis by (simp add: True lc_def) next case False show ?thesis proof (induct p rule: punit.poly_mapping_tail_induct) case 0 show ?case by simp next case (tail p) from False have "lc f ≠ 0" by (rule lc_not_0) from tail(1) have "punit.lc p ≠ 0" by (rule punit.lc_not_0) let ?t = "punit.tail p ⊙ monomial (lc f) (lt f)" let ?m = "monom_mult (punit.lc p) (punit.lt p) (monomial (lc f) (lt f))" from ‹lc f ≠ 0› have kt: "keys ?t = (λt. t ⊕ lt f) ` keys (punit.tail p)" by (rule keys_mult_scalar_monomial_right) have km: "keys ?m = {punit.lt p ⊕ lt f}" by (simp add: keys_monom_mult[OF ‹punit.lc p ≠ 0›] ‹lc f ≠ 0›) from tail(2) have "(red {f})⇧*⇧* (?t + ?m) (- punit.tail p ⊙ tail f + ?m)" proof (rule red_rtrancl_plus_higher) fix u v assume "u ∈ keys ?t" and "v ∈ keys ?m" from this(1) obtain s where "s ∈ keys (punit.tail p)" and u: "u = s ⊕ lt f" unfolding kt .. from this(1) have "punit.tail p ≠ 0" and "s ≼ punit.lt (punit.tail p)" using punit.lt_max by (auto simp: in_keys_iff) moreover from ‹punit.tail p ≠ 0› have "punit.lt (punit.tail p) ≺ punit.lt p" by (rule punit.lt_tail) ultimately have "s ≺ punit.lt p" by simp moreover from ‹v ∈ keys ?m› have "v = punit.lt p ⊕ lt f" by (simp only: km, simp) ultimately show "u ≺⇩t v" by (simp add: u splus_mono_strict_left) qed hence *: "(red {f})⇧*⇧* (p ⊙ monomial (lc f) (lt f)) (?m - punit.tail p ⊙ tail f)" by (simp add: punit.leading_monomial_tail[symmetric, of p] mult_scalar_monomial[symmetric] mult_scalar_distrib_right[symmetric] add.commute[of "punit.tail p"]) have "red {f} ?m (- (monomial (punit.lc p) (punit.lt p)) ⊙ tail f)" unfolding red_singleton proof show "red_single ?m (- (monomial (punit.lc p) (punit.lt p)) ⊙ tail f) f (punit.lt p)" proof (simp add: red_single_def ‹f ≠ 0› km lookup_monom_mult ‹lc f ≠ 0› ‹punit.lc p ≠ 0› term_simps, simp add: monom_mult_dist_right_minus[symmetric] mult_scalar_monomial) have "monom_mult (punit.lc p) (punit.lt p) (monomial (lc f) (lt f) - f) = - monom_mult (punit.lc p) (punit.lt p) (f - monomial (lc f) (lt f))" by (metis minus_diff_eq monom_mult_uminus_right) also have "... = - monom_mult (punit.lc p) (punit.lt p) (tail f)" by (simp only: tail_alt_2) finally show "- monom_mult (punit.lc p) (punit.lt p) (tail f) = monom_mult (punit.lc p) (punit.lt p) (monomial (lc f) (lt f) - f)" by simp qed qed hence "red {f} (?m + (- punit.tail p ⊙ tail f)) (- (monomial (punit.lc p) (punit.lt p)) ⊙ tail f + (- punit.tail p ⊙ tail f))" proof (rule red_plus_keys_disjoint) show "keys ?m ∩ keys (- punit.tail p ⊙ tail f) = {}" proof (cases "punit.tail p = 0") case True show ?thesis by (simp add: True) next case False from tail(2) have "- punit.tail p ⊙ tail f ≼⇩p ?t" by (rule red_rtrancl_ord) hence "lt (- punit.tail p ⊙ tail f) ≼⇩t lt ?t" by (rule ord_p_lt) also from ‹lc f ≠ 0› False have "... = punit.lt (punit.tail p) ⊕ lt f" by (rule lt_mult_scalar_monomial_right) also from punit.lt_tail[OF False] have "... ≺⇩t punit.lt p ⊕ lt f" by (rule splus_mono_strict_left) finally have "punit.lt p ⊕ lt f ∉ keys (- punit.tail p ⊙ tail f)" using lt_gr_keys by blast thus ?thesis by (simp add: km) qed qed hence "red {f} (?m - punit.tail p ⊙ tail f) (- (monomial (punit.lc p) (punit.lt p)) ⊙ tail f - punit.tail p ⊙ tail f)" by (simp add: term_simps) also have "... = - p ⊙ tail f" using punit.leading_monomial_tail[symmetric, of p] by (metis (mono_tags, lifting) add_uminus_conv_diff minus_add_distrib mult_scalar_distrib_right mult_scalar_minus_mult_left) finally have "red {f} (?m - punit.tail p ⊙ tail f) (- p ⊙ tail f)" . with * show ?case .. qed qed corollary red_mult_scalar_lt: assumes "f ≠ 0" shows "(red {f})⇧*⇧* (p ⊙ monomial c (lt f)) (monom_mult (- c / lc f) 0 (p ⊙ tail f))" proof - from assms have "lc f ≠ 0" by (rule lc_not_0) hence 1: "p ⊙ monomial c (lt f) = punit.monom_mult (c / lc f) 0 p ⊙ monomial (lc f) (lt f)" by (simp add: punit.mult_scalar_monomial[symmetric] mult.commute mult_scalar_assoc mult_scalar_monomial_monomial term_simps) have 2: "monom_mult (- c / lc f) 0 (p ⊙ tail f) = - punit.monom_mult (c / lc f) 0 p ⊙ tail f" by (simp add: times_monomial_left[symmetric] mult_scalar_assoc monom_mult_uminus_left mult_scalar_monomial) show ?thesis unfolding 1 2 by (fact red_mult_scalar_leading_monomial) qed lemma is_red_monomial_iff: "is_red F (monomial c v) ⟷ (c ≠ 0 ∧ (∃f∈F. f ≠ 0 ∧ lt f adds⇩t v))" by (simp add: is_red_adds_iff) lemma is_red_monomialI: assumes "c ≠ 0" and "f ∈ F" and "f ≠ 0" and "lt f adds⇩t v" shows "is_red F (monomial c v)" unfolding is_red_monomial_iff using assms by blast lemma is_red_monomialD: assumes "is_red F (monomial c v)" shows "c ≠ 0" using assms unfolding is_red_monomial_iff .. lemma is_red_monomialE: assumes "is_red F (monomial c v)" obtains f where "f ∈ F" and "f ≠ 0" and "lt f adds⇩t v" using assms unfolding is_red_monomial_iff by blast lemma replace_lt_adds_stable_is_red: assumes red: "is_red F f" and "q ≠ 0" and "lt q adds⇩t lt p" shows "is_red (insert q (F - {p})) f" proof - from red obtain g v where "g ∈ F" and "g ≠ 0" and "v ∈ keys f" and "lt g adds⇩t v" by (rule is_red_addsE) show ?thesis proof (cases "g = p") case True show ?thesis proof (rule is_red_addsI) show "q ∈ insert q (F - {p})" by simp next have "lt q adds⇩t lt p" by fact also have "... adds⇩t v" using ‹lt g adds⇩t v› unfolding True . finally show "lt q adds⇩t v" . qed (fact+) next case False with ‹g ∈ F› have "g ∈ insert q (F - {p})" by blast from this ‹g ≠ 0› ‹v ∈ keys f› ‹lt g adds⇩t v› show ?thesis by (rule is_red_addsI) qed qed lemma conversion_property: assumes "is_red {p} f" and "red {r} p q" shows "is_red {q} f ∨ is_red {r} f" proof - let ?s = "lp p - lp r" from ‹is_red {p} f› obtain v where "v ∈ keys f" and "lt p adds⇩t v" and "p ≠ 0" by (rule is_red_addsE, simp) from red_indE[OF ‹red {r} p q›] have "(r ≠ 0 ∧ lt r adds⇩t lt p ∧ q = p - monom_mult (lc p / lc r) ?s r) ∨ red {r} (tail p) (q - monomial (lc p) (lt p))" by simp thus ?thesis proof assume "r ≠ 0 ∧ lt r adds⇩t lt p ∧ q = p - monom_mult (lc p / lc r) ?s r" hence "r ≠ 0" and "lt r adds⇩t lt p" by simp_all show ?thesis by (intro disjI2, rule is_red_singleton_trans, rule ‹is_red {p} f›, fact+) next assume "red {r} (tail p) (q - monomial (lc p) (lt p))" (is "red _ ?p' ?q'") with red_ord have "?q' ≺⇩p ?p'" . hence "?p' ≠ 0" and assm: "(?q' = 0 ∨ ((lt ?q') ≺⇩t (lt ?p') ∨ (lt ?q') = (lt ?p')))" unfolding ord_strict_p_rec[of ?q' ?p'] by (auto simp add: Let_def lc_def) have "lt ?p' ≺⇩t lt p" by (rule lt_tail, fact) let ?m = "monomial (lc p) (lt p)" from monomial_0D[of "lt p" "lc p"] lc_not_0[OF ‹p ≠ 0›] have "?m ≠ 0" by blast have "lt ?m = lt p" by (rule lt_monomial, rule lc_not_0, fact) have "q ≠ 0 ∧ lt q = lt p" proof (cases "?q' = 0") case True hence "q = ?m" by simp with ‹?m ≠ 0› ‹lt ?m = lt p› show ?thesis by simp next case False from assm show ?thesis proof assume "(lt ?q') ≺⇩t (lt ?p') ∨ (lt ?q') = (lt ?p')" hence "lt ?q' ≼⇩t lt ?p'" by auto also have "... ≺⇩t lt p" by fact finally have "lt ?q' ≺⇩t lt p" . hence "lt ?q' ≺⇩t lt ?m" unfolding ‹lt ?m = lt p› . from lt_plus_eqI[OF this] ‹lt ?m = lt p› have "lt q = lt p" by simp show ?thesis proof (intro conjI, rule ccontr) assume "¬ q ≠ 0" hence "q = 0" by simp hence "?q' = -?m" by simp hence "lt ?q' = lt (-?m)" by simp also have "... = lt ?m" using lt_uminus . finally have "lt ?q' = lt ?m" . with ‹lt ?q' ≺⇩t lt ?m› show False by simp qed (fact) next assume "?q' = 0" with False show ?thesis .. qed qed hence "q ≠ 0" and "lt q adds⇩t lt p" by (simp_all add: term_simps) show ?thesis by (intro disjI1, rule is_red_singleton_trans, rule ‹is_red {p} f›, fact+) qed qed lemma replace_red_stable_is_red: assumes a1: "is_red F f" and a2: "red (F - {p}) p q" shows "is_red (insert q (F - {p})) f" (is "is_red ?F' f") proof - from a1 obtain g where "g ∈ F" and "is_red {g} f" by (rule is_red_singletonI) show ?thesis proof (cases "g = p") case True from a2 obtain h where "h ∈ F - {p}" and "red {h} p q" unfolding red_def by auto from ‹is_red {g} f› have "is_red {p} f" unfolding True . have "is_red {q} f ∨ is_red {h} f" by (rule conversion_property, fact+) thus ?thesis proof assume "is_red {q} f" show ?thesis proof (rule is_red_singletonD) show "q ∈ ?F'" by auto qed fact next assume "is_red {h} f" show ?thesis proof (rule is_red_singletonD) from ‹h ∈ F - {p}› show "h ∈ ?F'" by simp qed fact qed next case False show ?thesis proof (rule is_red_singletonD) from ‹g ∈ F› False show "g ∈ ?F'" by blast qed fact qed qed lemma is_red_map_scale: assumes "is_red F (c ⋅ p)" shows "is_red F p" proof - from assms obtain f u where "f ∈ F" and "u ∈ keys (c ⋅ p)" and "f ≠ 0" and a: "lt f adds⇩t u" by (rule is_red_addsE) from this(2) keys_map_scale_subset have "u ∈ keys p" .. with ‹f ∈ F› ‹f ≠ 0› show ?thesis using a by (rule is_red_addsI) qed corollary is_irred_map_scale: "¬ is_red F p ⟹ ¬ is_red F (c ⋅ p)" by (auto dest: is_red_map_scale) lemma is_red_map_scale_iff: "is_red F (c ⋅ p) ⟷ (c ≠ 0 ∧ is_red F p)" proof (intro iffI conjI notI) assume "is_red F (c ⋅ p)" and "c = 0" thus False by (simp add: irred_0) next assume "is_red F (c ⋅ p)" thus "is_red F p" by (rule is_red_map_scale) next assume "c ≠ 0 ∧ is_red F p" hence "is_red F (inverse c ⋅ c ⋅ p)" by (simp add: map_scale_assoc) thus "is_red F (c ⋅ p)" by (rule is_red_map_scale) qed lemma is_red_uminus: "is_red F (- p) ⟷ is_red F p" by (auto elim!: is_red_addsE simp: keys_uminus intro: is_red_addsI) lemma is_red_plus: assumes "is_red F (p + q)" shows "is_red F p ∨ is_red F q" proof - from assms obtain f u where "f ∈ F" and "u ∈ keys (p + q)" and "f ≠ 0" and a: "lt f adds⇩t u" by (rule is_red_addsE) from this(2) have "u ∈ keys p ∪ keys q" by (meson Poly_Mapping.keys_add subsetD) thus ?thesis proof assume "u ∈ keys p" with ‹f ∈ F› ‹f ≠ 0› have "is_red F p" using a by (rule is_red_addsI) thus ?thesis .. next assume "u ∈ keys q" with ‹f ∈ F› ‹f ≠ 0› have "is_red F q" using a by (rule is_red_addsI) thus ?thesis .. qed qed lemma is_irred_plus: "¬ is_red F p ⟹ ¬ is_red F q ⟹ ¬ is_red F (p + q)" by (auto dest: is_red_plus) lemma is_red_minus: assumes "is_red F (p - q)" shows "is_red F p ∨ is_red F q" proof - from assms have "is_red F (p + (- q))" by simp hence "is_red F p ∨ is_red F (- q)" by (rule is_red_plus) thus ?thesis by (simp only: is_red_uminus) qed lemma is_irred_minus: "¬ is_red F p ⟹ ¬ is_red F q ⟹ ¬ is_red F (p - q)" by (auto dest: is_red_minus) end (* ordered_term *) subsection ‹Well-foundedness and Termination› context gd_term begin lemma dgrad_set_le_red_single: assumes "dickson_grading d" and "red_single p q f t" shows "dgrad_set_le d {t} (pp_of_term ` keys p)" proof (rule dgrad_set_leI, simp) have "t adds t + lp f" by simp with assms(1) have "d t ≤ d (pp_of_term (t ⊕ lt f))" by (simp add: term_simps, rule dickson_grading_adds_imp_le) moreover from assms(2) have "t ⊕ lt f ∈ keys p" by (simp add: in_keys_iff red_single_def) ultimately show "∃v∈keys p. d t ≤ d (pp_of_term v)" .. qed lemma dgrad_p_set_le_red_single: assumes "dickson_grading d" and "red_single p q f t" shows "dgrad_p_set_le d {q} {f, p}" proof - let ?f = "monom_mult ((lookup p (t ⊕ lt f)) / lc f) t f" from assms(2) have "t ⊕ lt f ∈ keys p" and q: "q = p - ?f" by (simp_all add: red_single_def in_keys_iff) have "dgrad_p_set_le d {q} {p, ?f}" unfolding q by (fact dgrad_p_set_le_minus) also have "dgrad_p_set_le d ... {f, p}" proof (rule dgrad_p_set_leI_insert) from assms(1) have "dgrad_set_le d (pp_of_term ` keys ?f) (insert t (pp_of_term ` keys f))" by (rule dgrad_set_le_monom_mult) also have "dgrad_set_le d ... (pp_of_term ` (keys f ∪ keys p))" proof (rule dgrad_set_leI, simp) fix s assume "s = t ∨ s ∈ pp_of_term ` keys f" thus "∃u∈keys f ∪ keys p. d s ≤ d (pp_of_term u)" proof assume "s = t" from assms have "dgrad_set_le d {s} (pp_of_term ` keys p)" unfolding ‹s = t› by (rule dgrad_set_le_red_single) moreover have "s ∈ {s}" .. ultimately obtain s0 where "s0 ∈ pp_of_term ` keys p" and "d s ≤ d s0" by (rule dgrad_set_leE) from this(1) obtain u where "u ∈ keys p" and "s0 = pp_of_term u" .. from this(1) have "u ∈ keys f ∪ keys p" by simp with ‹d s ≤ d s0› show ?thesis unfolding ‹s0 = pp_of_term u› .. next assume "s ∈ pp_of_term ` keys f" hence "s ∈ pp_of_term ` (keys f ∪ keys p)" by blast then obtain u where "u ∈ keys f ∪ keys p" and "s = pp_of_term u" .. note this(1) moreover have "d s ≤ d s" .. ultimately show ?thesis unfolding ‹s = pp_of_term u› .. qed qed finally show "dgrad_p_set_le d {?f} {f, p}" by (simp add: dgrad_p_set_le_def Keys_insert) next show "dgrad_p_set_le d {p} {f, p}" by (rule dgrad_p_set_le_subset, simp) qed finally show ?thesis . qed lemma dgrad_p_set_le_red: assumes "dickson_grading d" and "red F p q" shows "dgrad_p_set_le d {q} (insert p F)" proof - from assms(2) obtain f t where "f ∈ F" and "red_single p q f t" by (rule red_setE) from assms(1) this(2) have "dgrad_p_set_le d {q} {f, p}" by (rule dgrad_p_set_le_red_single) also have "dgrad_p_set_le d ... (insert p F)" by (rule dgrad_p_set_le_subset, auto intro: ‹f ∈ F›) finally show ?thesis . qed corollary dgrad_p_set_le_red_rtrancl: assumes "dickson_grading d" and "(red F)⇧*⇧* p q" shows "dgrad_p_set_le d {q} (insert p F)" using assms(2) proof (induct) case base show ?case by (rule dgrad_p_set_le_subset, simp) next case (step y z) from assms(1) step(2) have "dgrad_p_set_le d {z} (insert y F)" by (rule dgrad_p_set_le_red) also have "dgrad_p_set_le d ... (insert p F)" proof (rule dgrad_p_set_leI_insert) show "dgrad_p_set_le d F (insert p F)" by (rule dgrad_p_set_le_subset, blast) qed fact finally show ?case . qed lemma dgrad_p_set_red_single_pp: assumes "dickson_grading d" and "p ∈ dgrad_p_set d m" and "red_single p q f t" shows "d t ≤ m" proof - from assms(1) assms(3) have "dgrad_set_le d {t} (pp_of_term ` keys p)" by (rule dgrad_set_le_red_single) moreover have "t ∈ {t}" .. ultimately obtain s where "s ∈ pp_of_term ` keys p" and "d t ≤ d s" by (rule dgrad_set_leE) from this(1) obtain u where "u ∈ keys p" and "s = pp_of_term u" .. from assms(2) this(1) have "d (pp_of_term u) ≤ m" by (rule dgrad_p_setD) with ‹d t ≤ d s› show ?thesis unfolding ‹s = pp_of_term u› by (rule le_trans) qed lemma dgrad_p_set_closed_red_single: assumes "dickson_grading d" and "p ∈ dgrad_p_set d m" and "f ∈ dgrad_p_set d m" and "red_single p q f t" shows "q ∈ dgrad_p_set d m" proof - from dgrad_p_set_le_red_single[OF assms(1, 4)] have "{q} ⊆ dgrad_p_set d m" proof (rule dgrad_p_set_le_dgrad_p_set) from assms(2, 3) show "{f, p} ⊆ dgrad_p_set d m" by simp qed thus ?thesis by simp qed lemma dgrad_p_set_closed_red: assumes "dickson_grading d" and "F ⊆ dgrad_p_set d m" and "p ∈ dgrad_p_set d m" and "red F p q" shows "q ∈ dgrad_p_set d m" proof - from assms(4) obtain f t where "f ∈ F" and *: "red_single p q f t" by (rule red_setE) from assms(2) this(1) have "f ∈ dgrad_p_set d m" .. from assms(1) assms(3) this * show ?thesis by (rule dgrad_p_set_closed_red_single) qed lemma dgrad_p_set_closed_red_rtrancl: assumes "dickson_grading d" and "F ⊆ dgrad_p_set d m" and "p ∈ dgrad_p_set d m" and "(red F)⇧*⇧* p q" shows "q ∈ dgrad_p_set d m" using assms(4) proof (induct) case base from assms(3) show ?case . next case (step r q) from assms(1) assms(2) step(3) step(2) show "q ∈ dgrad_p_set d m" by (rule dgrad_p_set_closed_red) qed lemma red_rtrancl_repE: assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m" and "finite G" and "p ∈ dgrad_p_set d m" and "(red G)⇧*⇧* p r" obtains q where "p = r + (∑g∈G. q g ⊙ g)" and "⋀g. q g ∈ punit.dgrad_p_set d m" and "⋀g. lt (q g ⊙ g) ≼⇩t lt p" using assms(5) proof (induct r arbitrary: thesis) case base show ?case proof (rule base) show "p = p + (∑g∈G. 0 ⊙ g)" by simp qed (simp_all add: punit.zero_in_dgrad_p_set min_term_min) next case (step r' r) from step.hyps(2) obtain g t where "g ∈ G" and rs: "red_single r' r g t" by (rule red_setE) from this(2) have "r' = r + monomial (lookup r' (t ⊕ lt g) / lc g) t ⊙ g" by (simp add: red_single_def mult_scalar_monomial) moreover define q0 where "q0 = monomial (lookup r' (t ⊕ lt g) / lc g) t" ultimately have r': "r' = r + q0 ⊙ g" by simp obtain q' where p: "p = r' + (∑g∈G. q' g ⊙ g)" and 1: "⋀g. q' g ∈ punit.dgrad_p_set d m" and 2: "⋀g. lt (q' g ⊙ g) ≼⇩t lt p" by (rule step.hyps) blast define q where "q = q'(g := q0 + q' g)" show ?case proof (rule step.prems) from assms(3) ‹g ∈ G› have "p = (r + q0 ⊙ g) + (q' g ⊙ g + (∑g∈G - {g}. q' g ⊙ g))" by (simp add: p r' sum.remove) also have "… = r + (q g ⊙ g + (∑g∈G - {g}. q' g ⊙ g))" by (simp add: q_def mult_scalar_distrib_right) also from refl have "(∑g∈G - {g}. q' g ⊙ g) = (∑g∈G - {g}. q g ⊙ g)" by (rule sum.cong) (simp add: q_def) finally show "p = r + (∑g∈G. q g ⊙ g)" using assms(3) ‹g ∈ G› by (simp only: sum.remove) next fix g0 have "q g0 ∈ punit.dgrad_p_set d m ∧ lt (q g0 ⊙ g0) ≼⇩t lt p" proof (cases "g0 = g") case True have eq: "q g = q0 + q' g" by (simp add: q_def) show ?thesis unfolding True eq proof from assms(1, 2, 4) step.hyps(1) have "r' ∈ dgrad_p_set d m" by (rule dgrad_p_set_closed_red_rtrancl) with assms(1) have "d t ≤ m" using rs by (rule dgrad_p_set_red_single_pp) hence "q0 ∈ punit.dgrad_p_set d m" by (simp add: q0_def punit.dgrad_p_set_def dgrad_set_def) thus "q0 + q' g ∈ punit.dgrad_p_set d m" by (intro punit.dgrad_p_set_closed_plus 1) next have "lt (q0 ⊙ g + q' g ⊙ g) ≼⇩t ord_term_lin.max (lt (q0 ⊙ g)) (lt (q' g ⊙ g))" by (fact lt_plus_le_max) also have "… ≼⇩t lt p" proof (intro ord_term_lin.max.boundedI 2) have "lt (q0 ⊙ g) ≼⇩t t ⊕ lt g" by (simp add: q0_def mult_scalar_monomial lt_monom_mult_le) also from rs have "… ≼⇩t lt r'" by (intro lt_max) (simp add: red_single_def) also from step.hyps(1) have "… ≼⇩t lt p" by (intro ord_p_lt red_rtrancl_ord) finally show "lt (q0 ⊙ g) ≼⇩t lt p" . qed finally show "lt ((q0 + q' g) ⊙ g) ≼⇩t lt p" by (simp only: mult_scalar_distrib_right) qed next case False hence "q g0 = q' g0" by (simp add: q_def) thus ?thesis by (simp add: 1 2) qed thus "q g0 ∈ punit.dgrad_p_set d m" and "lt (q g0 ⊙ g0) ≼⇩t lt p" by simp_all qed qed lemma is_relation_order_red: assumes "dickson_grading d" shows "Confluence.relation_order (red F) (≺⇩p) (dgrad_p_set d m)" proof show "wfp_on (≺⇩p) (dgrad_p_set d m)" proof (rule wfp_onI_min) fix x::"'t ⇒⇩0 'c" and Q assume "x ∈ Q" and "Q ⊆ dgrad_p_set d m" with assms obtain q where "q ∈ Q" and *: "⋀y. y ≺⇩p q ⟹ y ∉ Q" by (rule ord_p_minimum_dgrad_p_set, auto) from this(1) show "∃z∈Q. ∀y∈dgrad_p_set d m. y ≺⇩p z ⟶ y ∉ Q" proof from * show "∀y∈dgrad_p_set d m. y ≺⇩p q ⟶ y ∉ Q" by auto qed qed next show "red F ≤ (≺⇩p)¯¯" by (simp add: predicate2I red_ord) qed (fact ord_strict_p_transitive) lemma red_wf_dgrad_p_set_aux: assumes "dickson_grading d" and "F ⊆ dgrad_p_set d m" shows "wfp_on (red F)¯¯ (dgrad_p_set d m)" proof (rule wfp_onI_min) fix x::"'t ⇒⇩0 'b" and Q assume "x ∈ Q" and "Q ⊆ dgrad_p_set d m" with assms(1) obtain q where "q ∈ Q" and *: "⋀y. y ≺⇩p q ⟹ y ∉ Q" by (rule ord_p_minimum_dgrad_p_set, auto) from this(1) show "∃z∈Q. ∀y∈dgrad_p_set d m. (red F)¯¯ y z ⟶ y ∉ Q" proof show "∀y∈dgrad_p_set d m. (red F)¯¯ y q ⟶ y ∉ Q" proof (intro ballI impI, simp) fix y assume "red F q y" hence "y ≺⇩p q" by (rule red_ord) thus "y ∉ Q" by (rule *) qed qed qed lemma red_wf_dgrad_p_set: assumes "dickson_grading d" and "F ⊆ dgrad_p_set d m" shows "wfP (red F)¯¯" proof (rule wfI_min[to_pred]) fix x::"'t ⇒⇩0 'b" and Q assume "x ∈ Q" from assms(2) obtain n where "m ≤ n" and "x ∈ dgrad_p_set d n" and "F ⊆ dgrad_p_set d n" by (rule dgrad_p_set_insert) let ?Q = "Q ∩ dgrad_p_set d n" from assms(1) ‹F ⊆ dgrad_p_set d n› have "wfp_on (red F)¯¯ (dgrad_p_set d n)" by (rule red_wf_dgrad_p_set_aux) moreover from ‹x ∈ Q› ‹x ∈ dgrad_p_set d n› have "x ∈ ?Q" .. moreover have "?Q ⊆ dgrad_p_set d n" by simp ultimately obtain z where "z ∈ ?Q" and *: "⋀y. (red F)¯¯ y z ⟹ y ∉ ?Q" by (rule wfp_onE_min) blast from this(1) have "z ∈ Q" and "z ∈ dgrad_p_set d n" by simp_all from this(1) show "∃z∈Q. ∀y. (red F)¯¯ y z ⟶ y ∉ Q" proof show "∀y. (red F)¯¯ y z ⟶ y ∉ Q" proof (intro allI impI) fix y assume "(red F)¯¯ y z" hence "red F z y" by simp with assms(1) ‹F ⊆ dgrad_p_set d n› ‹z ∈ dgrad_p_set d n› have "y ∈ dgrad_p_set d n" by (rule dgrad_p_set_closed_red) moreover from ‹(red F)¯¯ y z› have "y ∉ ?Q" by (rule *) ultimately show "y ∉ Q" by blast qed qed qed lemmas red_wf_finite = red_wf_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl] lemma cbelow_on_monom_mult: assumes "dickson_grading d" and "F ⊆ dgrad_p_set d m" and "d t ≤ m" and "c ≠ 0" and "cbelow_on (dgrad_p_set d m) (≺⇩p) z (λa b. red F a b ∨ red F b a) p q" shows "cbelow_on (dgrad_p_set d m) (≺⇩p) (monom_mult c t z) (λa b. red F a b ∨ red F b a) (monom_mult c t p) (monom_mult c t q)" using assms(5) proof (induct rule: cbelow_on_induct) case base show ?case unfolding cbelow_on_def proof (rule disjI1, intro conjI, fact refl) from assms(5) have "p ∈ dgrad_p_set d m" by (rule cbelow_on_first_in) with assms(1) assms(3) show "monom_mult c t p ∈ dgrad_p_set d m" by (rule dgrad_p_set_closed_monom_mult) next from assms(5) have "p ≺⇩p z" by (rule cbelow_on_first_below) from this assms(4) show "monom_mult c t p ≺⇩p monom_mult c t z" by (rule ord_strict_p_monom_mult) qed next case (step q' q) let ?R = "λa b. red F a b ∨ red F b a" from step(5) show ?case proof from assms(1) assms(3) step(3) show "monom_mult c t q ∈ dgrad_p_set d m" by (rule dgrad_p_set_closed_monom_mult) next from step(2) red_monom_mult[OF _ assms(4)] show "?R (monom_mult c t q') (monom_mult c t q)" by auto next from step(4) assms(4) show "monom_mult c t q ≺⇩p monom_mult c t z" by (rule ord_strict_p_monom_mult) qed qed lemma cbelow_on_monom_mult_monomial: assumes "c ≠ 0" and "cbelow_on (dgrad_p_set d m) (≺⇩p) (monomial c' v) (λa b. red F a b ∨ red F b a) p q" shows "cbelow_on (dgrad_p_set d m) (≺⇩p) (monomial c (t ⊕ v)) (λa b. red F a b ∨ red F b a) p q" proof - have *: "f ≺⇩p monomial c' v ⟹ f ≺⇩p monomial c (t ⊕ v)" for f proof (simp add: ord_strict_p_monomial_iff assms(1), elim conjE disjE, erule disjI1, rule disjI2) assume "lt f ≺⇩t v" also have "... ≼⇩t t ⊕ v" using local.zero_min using splus_mono_left splus_zero by fastforce finally show "lt f ≺⇩t t ⊕ v" . qed from assms(2) show ?thesis proof (induct rule: cbelow_on_induct) case base show ?case unfolding cbelow_on_def proof (rule disjI1, intro conjI, fact refl) from assms(2) show "p ∈ dgrad_p_set d m" by (rule cbelow_on_first_in) next from assms(2) have "p ≺⇩p monomial c' v" by (rule cbelow_on_first_below) thus "p ≺⇩p monomial c (t ⊕ v)" by (rule *) qed next case (step q' q) let ?R = "λa b. red F a b ∨ red F b a" from step(5) step(3) step(2) show ?case proof from step(4) show "q ≺⇩p monomial c (t ⊕ v)" by (rule *) qed qed qed lemma cbelow_on_plus: assumes "dickson_grading d" and "F ⊆ dgrad_p_set d m" and "r ∈ dgrad_p_set d m" and "keys r ∩ keys z = {}" and "cbelow_on (dgrad_p_set d m) (≺⇩p) z (λa b. red F a b ∨ red F b a) p q" shows "cbelow_on (dgrad_p_set d m) (≺⇩p) (z + r) (λa b. red F a b ∨ red F b a) (p + r) (q + r)" using assms(5) proof (induct rule: cbelow_on_induct) case base show ?case unfolding cbelow_on_def proof (rule disjI1, intro conjI, fact refl) from assms(5) have "p ∈ dgrad_p_set d m" by (rule cbelow_on_first_in) from this assms(3) show "p + r ∈ dgrad_p_set d m" by (rule dgrad_p_set_closed_plus) next from assms(5) have "p ≺⇩p z" by (rule cbelow_on_first_below) from this assms(4) show "p + r ≺⇩p z + r" by (rule ord_strict_p_plus) qed next case (step q' q) let ?RS = "λa b. red F a b ∨ red F b a" let ?A = "dgrad_p_set d m" let ?R = "red F" let ?ord = "(≺⇩p)" from assms(1) have ro: "relation_order ?R ?ord ?A" by (rule is_relation_order_red) have dw: "relation.dw_closed ?R ?A" by (rule relation.dw_closedI, rule dgrad_p_set_closed_red, rule assms(1), rule assms(2)) from step(2) have "relation.cs (red F) (q' + r) (q + r)" proof assume "red F q q'" hence "relation.cs (red F) (q + r) (q' + r)" by (rule red_plus_cs) thus ?thesis by (rule relation.cs_sym) next assume "red F q' q" thus ?thesis by (rule red_plus_cs) qed with ro dw have "cbelow_on ?A ?ord (z + r) ?RS (q' + r) (q + r)" proof (rule relation_order.cs_implies_cbelow_on) from step(1) have "q' ∈ ?A" by (rule cbelow_on_second_in) from this assms(3) show "q' + r ∈ ?A" by (rule dgrad_p_set_closed_plus) next from step(3) assms(3) show "q + r ∈ ?A" by (rule dgrad_p_set_closed_plus) next from step(1) have "q' ≺⇩p z" by (rule cbelow_on_second_below) from this assms(4) show "q' + r ≺⇩p z + r" by (rule ord_strict_p_plus) next from step(4) assms(4) show "q + r ≺⇩p z + r" by (rule ord_strict_p_plus) qed with step(5) show ?case by (rule cbelow_on_transitive) qed lemma is_full_pmdlI_lt_dgrad_p_set: assumes "dickson_grading d" and "B ⊆ dgrad_p_set d m" assumes "⋀k. k ∈ component_of_term ` Keys (B::('t ⇒⇩0 'b::field) set) ⟹ (∃b∈B. b ≠ 0 ∧ component_of_term (lt b) = k ∧ lp b = 0)" shows "is_full_pmdl B" proof (rule is_full_pmdlI) fix p::"'t ⇒⇩0 'b" from assms(1, 2) have "wfP (red B)¯¯" by (rule red_wf_dgrad_p_set) moreover assume "component_of_term ` keys p ⊆ component_of_term ` Keys B" ultimately show "p ∈ pmdl B" proof (induct p) case (less p) show ?case proof (cases "p = 0") case True show ?thesis by (simp add: True pmdl.span_zero) next case False hence "lt p ∈ keys p" by (rule lt_in_keys) hence "component_of_term (lt p) ∈ component_of_term ` keys p" by simp also have "... ⊆ component_of_term ` Keys B" by fact finally have "∃b∈B. b ≠ 0 ∧ component_of_term (lt b) = component_of_term (lt p) ∧ lp b = 0" by (rule assms(3)) then obtain b where "b ∈ B" and "b ≠ 0" and "component_of_term (lt b) = component_of_term (lt p)" and "lp b = 0" by blast from this(3, 4) have eq: "lp p ⊕ lt b = lt p" by (simp add: splus_def term_of_pair_pair) define q where "q = p - monom_mult (lookup p ((lp p) ⊕ lt b) / lc b) (lp p) b" have "red_single p q b (lp p)" by (auto simp: red_single_def ‹b ≠ 0› q_def eq ‹lt p ∈ keys p›) with ‹b ∈ B› have "red B p q" by (rule red_setI) hence "(red B)¯¯ q p" .. moreover have "component_of_term ` keys q ⊆ component_of_term ` Keys B" proof (rule subset_trans) from ‹red B p q› show "component_of_term ` keys q ⊆ component_of_term ` keys p ∪ component_of_term ` Keys B" by (rule components_red_subset) next from less(2) show "component_of_term ` keys p ∪ component_of_term ` Keys B ⊆ component_of_term ` Keys B" by blast qed ultimately have "q ∈ pmdl B" by (rule less.hyps) have "q + monom_mult (lookup p ((lp p) ⊕ lt b) / lc b) (lp p) b ∈ pmdl B" by (rule pmdl.span_add, fact, rule pmdl_closed_monom_mult, rule pmdl.span_base, fact) thus ?thesis by (simp add: q_def) qed qed qed lemmas is_full_pmdlI_lt_finite = is_full_pmdlI_lt_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl] end (* gd_term *) subsection ‹Algorithms› subsubsection ‹Function ‹find_adds›› context ordered_term begin primrec find_adds :: "('t ⇒⇩0 'b) list ⇒ 't ⇒ ('t ⇒⇩0 'b::zero) option" where "find_adds [] _ = None"| "find_adds (f # fs) u = (if f ≠ 0 ∧ lt f adds⇩t u then Some f else find_adds fs u)" lemma find_adds_SomeD1: assumes "find_adds fs u = Some f" shows "f ∈ set fs" using assms by (induct fs, simp, simp split: if_splits) lemma find_adds_SomeD2: assumes "find_adds fs u = Some f" shows "f ≠ 0" using assms by (induct fs, simp, simp split: if_splits) lemma find_adds_SomeD3: assumes "find_adds fs u = Some f" shows "lt f adds⇩t u" using assms by (induct fs, simp, simp split: if_splits) lemma find_adds_NoneE: assumes "find_adds fs u = None" and "f ∈ set fs" assumes "f = 0 ⟹ thesis" and "f ≠ 0 ⟹ ¬ lt f adds⇩t u ⟹ thesis" shows thesis using assms proof (induct fs arbitrary: thesis) case Nil from Nil(2) show ?case by simp next case (Cons a fs) from Cons(2) have 1: "a = 0 ∨ ¬ lt a adds⇩t u" and 2: "find_adds fs u = None" by (simp_all split: if_splits) from Cons(3) have "f = a ∨ f ∈ set fs" by simp thus ?case proof assume "f = a" show ?thesis proof (cases "a = 0") case True show ?thesis by (rule Cons(4), simp add: ‹f = a› True) next case False with 1 have *: "¬ lt a adds⇩t u" by simp show ?thesis by (rule Cons(5), simp_all add: ‹f = a› * False) qed next assume "f ∈ set fs" with 2 show ?thesis proof (rule Cons(1)) assume "f = 0" thus ?thesis by (rule Cons(4)) next assume "f ≠ 0" and "¬ lt f adds⇩t u" thus ?thesis by (rule Cons(5)) qed qed qed lemma find_adds_SomeD_red_single: assumes "p ≠ 0" and "find_adds fs (lt p) = Some f" shows "red_single p (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f)) f (lp p - lp f)" proof - let ?f = "monom_mult (lc p / lc f) (lp p - lp f) f" from assms(2) have "f ≠ 0" and "lt f adds⇩t lt p" by (rule find_adds_SomeD2, rule find_adds_SomeD3) from this(2) have eq: "(lp p - lp f) ⊕ lt f = lt p" by (simp add: adds_minus_splus adds_term_def term_of_pair_pair) from assms(1) have "lc p ≠ 0" by (rule lc_not_0) moreover from ‹f ≠ 0› have "lc f ≠ 0" by (rule lc_not_0) ultimately have "lc p / lc f ≠ 0" by simp hence "lt ?f = (lp p - lp f) ⊕ lt f" by (simp add: lt_monom_mult ‹f ≠ 0›) hence lt_f: "lt ?f = lt p" by (simp only: eq) have "lookup ?f (lt p) = lookup ?f ((lp p - lp f) ⊕ lt f)" by (simp only: eq) also have "... = (lc p / lc f) * lookup f (lt f)" by (rule lookup_monom_mult_plus) also from ‹lc f ≠ 0› have "... = lookup p (lt p)" by (simp add: lc_def) finally have lc_f: "lookup ?f (lt p) = lookup p (lt p)" . have "red_single p (p - ?f) f (lp p - lp f)" by (auto simp: red_single_def eq lc_def ‹f ≠ 0› lt_in_keys assms(1)) moreover have "p - ?f = tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f)" by (rule poly_mapping_eqI, simp add: tail_monom_mult[symmetric] lookup_minus lookup_tail_2 lt_f lc_f split: if_split) ultimately show ?thesis by simp qed lemma find_adds_SomeD_red: assumes "p ≠ 0" and "find_adds fs (lt p) = Some f" shows "red (set fs) p (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f))" proof (rule red_setI) from assms(2) show "f ∈ set fs" by (rule find_adds_SomeD1) next from assms show "red_single p (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f)) f (lp p - lp f)" by (rule find_adds_SomeD_red_single) qed end (* ordered_term *) subsubsection ‹Function ‹trd›› context gd_term begin definition trd_term :: "('a ⇒ nat) ⇒ ((('t ⇒⇩0 'b::field) list × ('t ⇒⇩0 'b) × ('t ⇒⇩0 'b)) × (('t ⇒⇩0 'b) list × ('t ⇒⇩0 'b) × ('t ⇒⇩0 'b))) set" where "trd_term d = {(x, y). dgrad_p_set_le d (set (fst (snd x) # fst x)) (set (fst (snd y) # fst y)) ∧ fst (snd x) ≺⇩p fst (snd y)}" lemma trd_term_wf: assumes "dickson_grading d" shows "wf (trd_term d)" proof (rule wfI_min) fix x :: "('t ⇒⇩0 'b::field) list × ('t ⇒⇩0 'b) × ('t ⇒⇩0 'b)" and Q assume "x ∈ Q" let ?A = "set (fst (snd x) # fst x)" have "finite ?A" .. then obtain m where A: "?A ⊆ dgrad_p_set d m" by (rule dgrad_p_set_exhaust) let ?B = "dgrad_p_set d m" let ?Q = "{q ∈ Q. set (fst (snd q) # fst q) ⊆ ?B}" note assms moreover have "fst (snd x) ∈ fst ` snd ` ?Q" by (rule, fact refl, rule, fact refl, simp only: mem_Collect_eq A ‹x ∈ Q›) moreover have "fst ` snd ` ?Q ⊆ ?B" by auto ultimately obtain z0 where "z0 ∈ fst ` snd ` ?Q" and *: "⋀y. y ≺⇩p z0 ⟹ y ∉ fst ` snd ` ?Q" by (rule ord_p_minimum_dgrad_p_set, blast) from this(1) obtain z where "z ∈ {q ∈ Q. set (fst (snd q) # fst q) ⊆ ?B}" and z0: "z0 = fst (snd z)" by fastforce from this(1) have "z ∈ Q" and a: "set (fst (snd z) # fst z) ⊆ ?B" by simp_all from this(1) show "∃z∈Q. ∀y. (y, z) ∈ trd_term d ⟶ y ∉ Q" proof show "∀y. (y, z) ∈ trd_term d ⟶ y ∉ Q" proof (intro allI impI) fix y assume "(y, z) ∈ trd_term d" hence b: "dgrad_p_set_le d (set (fst (snd y) # fst y)) (set (fst (snd z) # fst z))" and "fst (snd y) ≺⇩p z0" by (simp_all add: trd_term_def z0) from this(2) have "fst (snd y) ∉ fst ` snd ` ?Q" by (rule *) hence "y ∉ Q ∨ ¬ set (fst (snd y) # fst y) ⊆ ?B" by auto moreover from b a have "set (fst (snd y) # fst y) ⊆ ?B" by (rule dgrad_p_set_le_dgrad_p_set) ultimately show "y ∉ Q" by simp qed qed qed function trd_aux :: "('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b::field)" where "trd_aux fs p r = (if p = 0 then r else case find_adds fs (lt p) of None ⇒ trd_aux fs (tail p) (r + monomial (lc p) (lt p)) | Some f ⇒ trd_aux fs (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f)) r )" by auto termination proof - from ex_dgrad obtain d::"'a ⇒ nat" where dg: "dickson_grading d" .. let ?R = "trd_term d" show ?thesis proof (rule, rule trd_term_wf, fact) fix fs and p r::"'t ⇒⇩0 'b" assume "p ≠ 0" show "((fs, tail p, r + monomial (lc p) (lt p)), fs, p, r) ∈ trd_term d" proof (simp add: trd_term_def, rule) show "dgrad_p_set_le d (insert (tail p) (set fs)) (insert p (set fs))" proof (rule dgrad_p_set_leI_insert_keys, rule dgrad_p_set_le_subset, rule subset_insertI, rule dgrad_set_le_subset, simp add: Keys_insert image_Un) have "keys (tail p) ⊆ keys p" by (auto simp: keys_tail) hence "pp_of_term ` keys (tail p) ⊆ pp_of_term ` keys p" by (rule image_mono) thus "pp_of_term ` keys (tail p) ⊆ pp_of_term ` keys p ∪ pp_of_term ` Keys (set fs)" by blast qed next from ‹p ≠ 0› show "tail p ≺⇩p p" by (rule tail_ord_p) qed next fix fs::"('t ⇒⇩0 'b) list" and p r f ::"'t ⇒⇩0 'b" assume "p ≠ 0" and "find_adds fs (lt p) = Some f" hence "red (set fs) p (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f))" (is "red _ p ?q") by (rule find_adds_SomeD_red) show "((fs, ?q, r), fs, p, r) ∈ trd_term d" by (simp add: trd_term_def, rule, rule dgrad_p_set_leI_insert, rule dgrad_p_set_le_subset, rule subset_insertI, rule dgrad_p_set_le_red, fact dg, fact ‹red (set fs) p ?q›, rule red_ord, fact) qed qed definition trd :: "('t ⇒⇩0 'b::field) list ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b)" where "trd fs p = trd_aux fs p 0" lemma trd_aux_red_rtrancl: "(red (set fs))⇧*⇧* p (trd_aux fs p r - r)" proof (induct fs p r rule: trd_aux.induct) case (1 fs p r) show ?case proof (simp, split option.split, intro conjI impI allI) assume "p ≠ 0" and "find_adds fs (lt p) = None" hence "(red (set fs))⇧*⇧* (tail p) (trd_aux fs (tail p) (r + monomial (lc p) (lt p)) - (r + monomial (lc p) (lt p)))" by (rule 1(1)) hence "(red (set fs))⇧*⇧* (tail p + monomial (lc p) (lt p)) (trd_aux fs (tail p) (r + monomial (lc p) (lt p)) - (r + monomial (lc p) (lt p)) + monomial (lc p ) (lt p))" proof (rule red_rtrancl_plus_higher) fix u v assume "u ∈ keys (tail p)" assume "v ∈ keys (monomial (lc p) (lt p))" also have "... ⊆ {lt p}" by (simp add: keys_monomial) finally have "v = lt p" by simp from ‹u ∈ keys (tail p)› show "u ≺⇩t v" unfolding ‹v = lt p› by (rule keys_tail_less_lt) qed thus "(red (set fs))⇧*⇧* p (trd_aux fs (tail p) (r + monomial (lc p) (lt p)) - r)" by (simp only: leading_monomial_tail[symmetric] add.commute[of _ "monomial (lc p) (lt p)"], simp) next fix f assume "p ≠ 0" and "find_adds fs (lt p) = Some f" hence "(red (set fs))⇧*⇧* (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f)) (trd_aux fs (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f)) r - r)" and *: "red (set fs) p (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f))" by (rule 1(2), rule find_adds_SomeD_red) let ?q = "tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f)" from * have "(red (set fs))⇧*⇧* p ?q" .. moreover have "(red (set fs))⇧*⇧* ?q (trd_aux fs ?q r - r)" by fact ultimately show "(red (set fs))⇧*⇧* p (trd_aux fs ?q r - r)" by (rule rtranclp_trans) qed qed corollary trd_red_rtrancl: "(red (set fs))⇧*⇧* p (trd fs p)" proof - have "(red (set fs))⇧*⇧* p (trd fs p - 0)" unfolding trd_def by (rule trd_aux_red_rtrancl) thus ?thesis by simp qed lemma trd_aux_irred: assumes "¬ is_red (set fs) r" shows "¬ is_red (set fs) (trd_aux fs p r)" using assms proof (induct fs p r rule: trd_aux.induct) case (1 fs p r) show ?case proof (simp add: 1(3), split option.split, intro impI conjI allI) assume "p ≠ 0" and *: "find_adds fs (lt p) = None" thus "¬ is_red (set fs) (trd_aux fs (tail p) (r + monomial (lc p) (lt p)))" proof (rule 1(1)) show "¬ is_red (set fs) (r + monomial (lc p) (lt p))" proof assume "is_red (set fs) (r + monomial (lc p) (lt p))" then obtain f u where "f ∈ set fs" and "f ≠ 0" and "u ∈ keys (r + monomial (lc p) (lt p))" and "lt f adds⇩t u" by (rule is_red_addsE) note this(3) also have "keys (r + monomial (lc p) (lt p)) ⊆ keys r ∪ keys (monomial (lc p) (lt p))" by (rule Poly_Mapping.keys_add) also have "... ⊆ insert (lt p) (keys r)" by auto finally show False proof assume "u = lt p" from * ‹f ∈ set fs› show ?thesis proof (rule find_adds_NoneE) assume "f = 0" with ‹f ≠ 0› show ?thesis .. next assume "¬ lt f adds⇩t lt p" from this ‹lt f adds⇩t u› show ?thesis unfolding ‹u = lt p› .. qed next assume "u ∈ keys r" from ‹f ∈ set fs› ‹f ≠ 0› this ‹lt f adds⇩t u› have "is_red (set fs) r" by (rule is_red_addsI) with 1(3) show ?thesis .. qed qed qed next fix f assume "p ≠ 0" and "find_adds fs (lt p) = Some f" from this 1(3) show "¬ is_red (set fs) (trd_aux fs (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f)) r)" by (rule 1(2)) qed qed corollary trd_irred: "¬ is_red (set fs) (trd fs p)" unfolding trd_def using irred_0 by (rule trd_aux_irred) lemma trd_in_pmdl: "p - (trd fs p) ∈ pmdl (set fs)" using trd_red_rtrancl by (rule red_rtranclp_diff_in_pmdl) lemma pmdl_closed_trd: assumes "p ∈ pmdl B" and "set fs ⊆ pmdl B" shows "(trd fs p) ∈ pmdl B" proof - from assms(2) have "pmdl (set fs) ⊆ pmdl B" by (rule pmdl.span_subset_spanI) with trd_in_pmdl have "p - trd fs p ∈ pmdl B" .. with assms(1) have "p - (p - trd fs p) ∈ pmdl B" by (rule pmdl.span_diff) thus ?thesis by simp qed end (* gd_term *) end (* theory *)
Theory Groebner_Bases
(* Author: Fabian Immler, Alexander Maletzky *) section ‹Gr\"obner Bases and Buchberger's Theorem› theory Groebner_Bases imports Reduction begin text ‹This theory provides the main results about Gr\"obner bases for modules of multivariate polynomials.› context gd_term begin definition crit_pair :: "('t ⇒⇩0 'b::field) ⇒ ('t ⇒⇩0 'b) ⇒ (('t ⇒⇩0 'b) × ('t ⇒⇩0 'b))" where "crit_pair p q = (if component_of_term (lt p) = component_of_term (lt q) then (monom_mult (1 / lc p) ((lcs (lp p) (lp q)) - (lp p)) (tail p), monom_mult (1 / lc q) ((lcs (lp p) (lp q)) - (lp q)) (tail q)) else (0, 0))" definition crit_pair_cbelow_on :: "('a ⇒ nat) ⇒ nat ⇒ ('t ⇒⇩0 'b::field) set ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b) ⇒ bool" where "crit_pair_cbelow_on d m F p q ⟷ cbelow_on (dgrad_p_set d m) (≺⇩p) (monomial 1 (term_of_pair (lcs (lp p) (lp q), component_of_term (lt p)))) (λa b. red F a b ∨ red F b a) (fst (crit_pair p q)) (snd (crit_pair p q))" definition spoly :: "('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b::field)" where "spoly p q = (let v1 = lt p; v2 = lt q in if component_of_term v1 = component_of_term v2 then let t1 = pp_of_term v1; t2 = pp_of_term v2; l = lcs t1 t2 in (monom_mult (1 / lookup p v1) (l - t1) p) - (monom_mult (1 / lookup q v2) (l - t2) q) else 0)" definition (in ordered_term) is_Groebner_basis :: "('t ⇒⇩0 'b::field) set ⇒ bool" where "is_Groebner_basis F ≡ relation.is_ChurchRosser (red F)" subsection ‹Critical Pairs and S-Polynomials› lemma crit_pair_same: "fst (crit_pair p p) = snd (crit_pair p p)" by (simp add: crit_pair_def) lemma crit_pair_swap: "crit_pair p q = (snd (crit_pair q p), fst (crit_pair q p))" by (simp add: crit_pair_def lcs_comm) lemma crit_pair_zero [simp]: "fst (crit_pair 0 q) = 0" and "snd (crit_pair p 0) = 0" by (simp_all add: crit_pair_def) lemma dgrad_p_set_le_crit_pair_zero: "dgrad_p_set_le d {fst (crit_pair p 0)} {p}" proof (simp add: crit_pair_def lt_def[of 0] lcs_comm lcs_zero dgrad_p_set_le_def Keys_insert min_term_def term_simps, intro conjI impI dgrad_set_leI) fix s assume "s ∈ pp_of_term ` keys (monom_mult (1 / lc p) 0 (tail p))" then obtain v where "v ∈ keys (monom_mult (1 / lc p) 0 (tail p))" and "s = pp_of_term v" .. from this(1) keys_monom_mult_subset have "v ∈ (⊕) 0 ` keys (tail p)" .. hence "v ∈ keys (tail p)" by (simp add: image_iff term_simps) hence "v ∈ keys p" by (simp add: keys_tail) hence "s ∈ pp_of_term ` keys p" by (simp add: ‹s = pp_of_term v›) moreover have "d s ≤ d s" .. ultimately show "∃t∈pp_of_term ` keys p. d s ≤ d t" .. qed simp lemma dgrad_p_set_le_fst_crit_pair: assumes "dickson_grading d" shows "dgrad_p_set_le d {fst (crit_pair p q)} {p, q}" proof (cases "q = 0") case True have "dgrad_p_set_le d {fst (crit_pair p q)} {p}" unfolding True by (fact dgrad_p_set_le_crit_pair_zero) also have "dgrad_p_set_le d ... {p, q}" by (rule dgrad_p_set_le_subset, simp) finally show ?thesis . next case False show ?thesis proof (cases "p = 0") case True have "dgrad_p_set_le d {fst (crit_pair p q)} {q}" by (simp add: True dgrad_p_set_le_def dgrad_set_le_def) also have "dgrad_p_set_le d ... {p, q}" by (rule dgrad_p_set_le_subset, simp) finally show ?thesis . next case False show ?thesis proof (simp add: dgrad_p_set_le_def Keys_insert crit_pair_def, intro conjI impI) define t where "t = lcs (lp p) (lp q) - lp p" let ?m = "monom_mult (1 / lc p) t (tail p)" from assms have "dgrad_set_le d (pp_of_term ` keys ?m) (insert t (pp_of_term ` keys (tail p)))" by (rule dgrad_set_le_monom_mult) also have "dgrad_set_le d ... (pp_of_term ` (keys p ∪ keys q))" proof (rule dgrad_set_leI, simp) fix s assume "s = t ∨ s ∈ pp_of_term ` keys (tail p)" thus "∃v∈keys p ∪ keys q. d s ≤ d (pp_of_term v)" proof assume "s = t" from assms have "d s ≤ ord_class.max (d (lp p)) (d (lp q))" unfolding ‹s = t› t_def by (rule dickson_grading_lcs_minus) hence "d s ≤ d (lp p) ∨ d s ≤ d (lp q)" by auto thus ?thesis proof from ‹p ≠ 0› have "lt p ∈ keys p" by (rule lt_in_keys) hence "lt p ∈ keys p ∪ keys q" by simp moreover assume "d s ≤ d (lp p)" ultimately show ?thesis .. next from ‹q ≠ 0› have "lt q ∈ keys q" by (rule lt_in_keys) hence "lt q ∈ keys p ∪ keys q" by simp moreover assume "d s ≤ d (lp q)" ultimately show ?thesis .. qed next assume "s ∈ pp_of_term ` keys (tail p)" hence "s ∈ pp_of_term ` (keys p ∪ keys q)" by (auto simp: keys_tail) then obtain v where "v ∈ keys p ∪ keys q" and "s = pp_of_term v" .. note this(1) moreover have "d s ≤ d (pp_of_term v)" by (simp add: ‹s = pp_of_term v›) ultimately show ?thesis .. qed qed finally show "dgrad_set_le d (pp_of_term ` keys ?m) (pp_of_term ` (keys p ∪ keys q))" . qed (rule dgrad_set_leI, simp) qed qed lemma dgrad_p_set_le_snd_crit_pair: assumes "dickson_grading d" shows "dgrad_p_set_le d {snd (crit_pair p q)} {p, q}" by (simp add: crit_pair_swap[of p] insert_commute[of p q], rule dgrad_p_set_le_fst_crit_pair, fact) lemma dgrad_p_set_closed_fst_crit_pair: assumes "dickson_grading d" and "p ∈ dgrad_p_set d m" and "q ∈ dgrad_p_set d m" shows "fst (crit_pair p q) ∈ dgrad_p_set d m" proof - from dgrad_p_set_le_fst_crit_pair[OF assms(1)] have "{fst (crit_pair p q)} ⊆ dgrad_p_set d m" proof (rule dgrad_p_set_le_dgrad_p_set) from assms(2, 3) show "{p, q} ⊆ dgrad_p_set d m" by simp qed thus ?thesis by simp qed lemma dgrad_p_set_closed_snd_crit_pair: assumes "dickson_grading d" and "p ∈ dgrad_p_set d m" and "q ∈ dgrad_p_set d m" shows "snd (crit_pair p q) ∈ dgrad_p_set d m" by (simp add: crit_pair_swap[of p q], rule dgrad_p_set_closed_fst_crit_pair, fact+) lemma fst_crit_pair_below_lcs: "fst (crit_pair p q) ≺⇩p monomial 1 (term_of_pair (lcs (lp p) (lp q), component_of_term (lt p)))" proof (cases "tail p = 0") case True thus ?thesis by (simp add: crit_pair_def ord_strict_p_monomial_iff) next case False let ?t1 = "lp p" let ?t2 = "lp q" from False have "p ≠ 0" by auto hence "lc p ≠ 0" by (rule lc_not_0) hence "1 / lc p ≠ 0" by simp from this False have "lt (monom_mult (1 / lc p) (lcs ?t1 ?t2 - ?t1) (tail p)) = (lcs ?t1 ?t2 - ?t1) ⊕ lt (tail p)" by (rule lt_monom_mult) also from lt_tail[OF False] have "... ≺⇩t (lcs ?t1 ?t2 - ?t1) ⊕ lt p" by (rule splus_mono_strict) also from adds_lcs have "... = term_of_pair (lcs ?t1 ?t2, component_of_term (lt p))" by (simp add: adds_lcs adds_minus splus_def) finally show ?thesis by (auto simp add: crit_pair_def ord_strict_p_monomial_iff) qed lemma snd_crit_pair_below_lcs: "snd (crit_pair p q) ≺⇩p monomial 1 (term_of_pair (lcs (lp p) (lp q), component_of_term (lt p)))" proof (cases "component_of_term (lt p) = component_of_term (lt q)") case True show ?thesis by (simp add: True crit_pair_swap[of p] lcs_comm[of "lp p"], fact fst_crit_pair_below_lcs) next case False show ?thesis by (simp add: crit_pair_def False ord_strict_p_monomial_iff) qed lemma crit_pair_cbelow_same: assumes "dickson_grading d" and "p ∈ dgrad_p_set d m" shows "crit_pair_cbelow_on d m F p p" proof (simp add: crit_pair_cbelow_on_def crit_pair_same cbelow_on_def term_simps, intro disjI1 conjI) from assms(1) assms(2) assms(2) show "snd (crit_pair p p) ∈ dgrad_p_set d m" by (rule dgrad_p_set_closed_snd_crit_pair) next from snd_crit_pair_below_lcs[of p p] show "snd (crit_pair p p) ≺⇩p monomial 1 (lt p)" by (simp add: term_simps) qed lemma crit_pair_cbelow_distinct_component: assumes "component_of_term (lt p) ≠ component_of_term (lt q)" shows "crit_pair_cbelow_on d m F p q" by (simp add: crit_pair_cbelow_on_def crit_pair_def assms cbelow_on_def ord_strict_p_monomial_iff zero_in_dgrad_p_set) lemma crit_pair_cbelow_sym: assumes "crit_pair_cbelow_on d m F p q" shows "crit_pair_cbelow_on d m F q p" proof (cases "component_of_term (lt q) = component_of_term (lt p)") case True from assms show ?thesis proof (simp add: crit_pair_cbelow_on_def crit_pair_swap[of p q] lcs_comm True, elim cbelow_on_symmetric) show "symp (λa b. red F a b ∨ red F b a)" by (simp add: symp_def) qed next case False thus ?thesis by (rule crit_pair_cbelow_distinct_component) qed lemma crit_pair_cs_imp_crit_pair_cbelow_on: assumes "dickson_grading d" and "F ⊆ dgrad_p_set d m" and "p ∈ dgrad_p_set d m" and "q ∈ dgrad_p_set d m" and "relation.cs (red F) (fst (crit_pair p q)) (snd (crit_pair p q))" shows "crit_pair_cbelow_on d m F p q" proof - from assms(1) have "relation_order (red F) (≺⇩p) (dgrad_p_set d m)" by (rule is_relation_order_red) moreover have "relation.dw_closed (red F) (dgrad_p_set d m)" by (rule relation.dw_closedI, rule dgrad_p_set_closed_red, rule assms(1), rule assms(2)) moreover note assms(5) moreover from assms(1) assms(3) assms(4) have "fst (crit_pair p q) ∈ dgrad_p_set d m" by (rule dgrad_p_set_closed_fst_crit_pair) moreover from assms(1) assms(3) assms(4) have "snd (crit_pair p q) ∈ dgrad_p_set d m" by (rule dgrad_p_set_closed_snd_crit_pair) moreover note fst_crit_pair_below_lcs snd_crit_pair_below_lcs ultimately show ?thesis unfolding crit_pair_cbelow_on_def by (rule relation_order.cs_implies_cbelow_on) qed lemma crit_pair_cbelow_mono: assumes "crit_pair_cbelow_on d m F p q" and "F ⊆ G" shows "crit_pair_cbelow_on d m G p q" using assms(1) unfolding crit_pair_cbelow_on_def proof (induct rule: cbelow_on_induct) case base show ?case by (simp add: cbelow_on_def, intro disjI1 conjI, fact+) next case (step b c) from step(2) have "red G b c ∨ red G c b" using red_subset[OF _ assms(2)] by blast from step(5) step(3) this step(4) show ?case .. qed lemma lcs_red_single_fst_crit_pair: assumes "p ≠ 0" and "component_of_term (lt p) = component_of_term (lt q)" defines "t1 ≡ lp p" defines "t2 ≡ lp q" shows "red_single (monomial (- 1) (term_of_pair (lcs t1 t2, component_of_term (lt p)))) (fst (crit_pair p q)) p (lcs t1 t2 - t1)" proof - let ?l = "term_of_pair (lcs t1 t2, component_of_term (lt p))" from assms(1) have "lc p ≠ 0" by (rule lc_not_0) have "lt p adds⇩t ?l" by (simp add: adds_lcs adds_term_def t1_def term_simps) hence eq1: "(lcs t1 t2 - t1) ⊕ lt p = ?l" by (simp add: adds_lcs adds_minus splus_def t1_def) with assms(1) show ?thesis proof (simp add: crit_pair_def red_single_def assms(2)) have eq2: "monomial (- 1) ?l = monom_mult (- (1 / lc p)) (lcs t1 t2 - t1) (monomial (lc p) (lt p))" by (simp add: monom_mult_monomial eq1 ‹lc p ≠ 0›) show "monom_mult (1 / lc p) (lcs (lp p) (lp q) - lp p) (tail p) = monomial (- 1) (term_of_pair (lcs t1 t2, component_of_term (lt q))) - monom_mult (- (1 / lc p)) (lcs t1 t2 - t1) p" apply (simp add: t1_def t2_def monom_mult_dist_right_minus tail_alt_2 monom_mult_uminus_left) by (metis assms(2) eq2 monom_mult_uminus_left t1_def t2_def) qed qed corollary lcs_red_single_snd_crit_pair: assumes "q ≠ 0" and "component_of_term (lt p) = component_of_term (lt q)" defines "t1 ≡ lp p" defines "t2 ≡ lp q" shows "red_single (monomial (- 1) (term_of_pair (lcs t1 t2, component_of_term (lt p)))) (snd (crit_pair p q)) q (lcs t1 t2 - t2)" by (simp add: crit_pair_swap[of p q] lcs_comm[of "lp p"] assms(2) t1_def t2_def, rule lcs_red_single_fst_crit_pair, simp_all add: assms(1, 2)) lemma GB_imp_crit_pair_cbelow_dgrad_p_set: assumes "dickson_grading d" and "F ⊆ dgrad_p_set d m" and "is_Groebner_basis F" assumes "p ∈ F" and "q ∈ F" and "p ≠ 0" and "q ≠ 0" shows "crit_pair_cbelow_on d m F p q" proof (cases "component_of_term (lt p) = component_of_term (lt q)") case True from assms(1, 2) show ?thesis proof (rule crit_pair_cs_imp_crit_pair_cbelow_on) from assms(4, 2) show "p ∈ dgrad_p_set d m" .. next from assms(5, 2) show "q ∈ dgrad_p_set d m" .. next let ?cp = "crit_pair p q" let ?l = "monomial (- 1) (term_of_pair (lcs (lp p) (lp q), component_of_term (lt p)))" from assms(4) lcs_red_single_fst_crit_pair[OF assms(6) True] have "red F ?l (fst ?cp)" by (rule red_setI) hence 1: "(red F)⇧*⇧* ?l (fst ?cp)" .. from assms(5) lcs_red_single_snd_crit_pair[OF assms(7) True] have "red F ?l (snd ?cp)" by (rule red_setI) hence 2: "(red F)⇧*⇧* ?l (snd ?cp)" .. from assms(3) have "relation.is_confluent_on (red F) UNIV" by (simp only: is_Groebner_basis_def relation.confluence_equiv_ChurchRosser[symmetric] relation.is_confluent_def) from this 1 2 show "relation.cs (red F) (fst ?cp) (snd ?cp)" by (simp add: relation.is_confluent_on_def) qed next case False thus ?thesis by (rule crit_pair_cbelow_distinct_component) qed lemma spoly_alt: assumes "p ≠ 0" and "q ≠ 0" shows "spoly p q = fst (crit_pair p q) - snd (crit_pair p q)" proof (cases "component_of_term (lt p) = component_of_term (lt q)") case ec: True show ?thesis proof (rule poly_mapping_eqI, simp only: lookup_minus) fix v define t1 where "t1 = lp p" define t2 where "t2 = lp q" let ?l = "lcs t1 t2" let ?lv = "term_of_pair (?l, component_of_term (lt p))" let ?cp = "crit_pair p q" let ?a = "λx. monom_mult (1 / lc p) (?l - t1) x" let ?b = "λx. monom_mult (1 / lc q) (?l - t2) x" have l_1: "(?l - t1) ⊕ lt p = ?lv" by (simp add: adds_lcs adds_minus splus_def t1_def) have l_2: "(?l - t2) ⊕ lt q = ?lv" by (simp add: ec adds_lcs_2 adds_minus splus_def t2_def) show "lookup (spoly p q) v = lookup (fst ?cp) v - lookup (snd ?cp) v" proof (cases "v = ?lv") case True have v_1: "v = (?l - t1) ⊕ lt p" by (simp add: True l_1) from ‹p ≠ 0› have "lt p ∈ keys p" by (rule lt_in_keys) hence v_2: "v = (?l - t2) ⊕ lt q" by (simp add: True l_2) from ‹q ≠ 0› have "lt q ∈ keys q" by (rule lt_in_keys) from ‹lt p ∈ keys p› have "lookup (?a p) v = 1" by (simp add: in_keys_iff v_1 lookup_monom_mult lc_def term_simps) also from ‹lt q ∈ keys q› have "... = lookup (?b q) v" by (simp add: in_keys_iff v_2 lookup_monom_mult lc_def term_simps) finally have "lookup (spoly p q) v = 0" by (simp add: spoly_def ec Let_def t1_def t2_def lookup_minus lc_def) moreover have "lookup (fst ?cp) v = 0" by (simp add: crit_pair_def ec v_1 lookup_monom_mult t1_def t2_def term_simps, simp only: not_in_keys_iff_lookup_eq_zero[symmetric] keys_tail, simp) moreover have "lookup (snd ?cp) v = 0" by (simp add: crit_pair_def ec v_2 lookup_monom_mult t1_def t2_def term_simps, simp only: not_in_keys_iff_lookup_eq_zero[symmetric] keys_tail, simp) ultimately show ?thesis by simp next case False have "lookup (?a (tail p)) v = lookup (?a p) v" proof (cases "?l - t1 adds⇩p v") case True then obtain u where v: "v = (?l - t1) ⊕ u" .. have "u ≠ lt p" proof assume "u = lt p" hence "v = ?lv" by (simp add: v l_1) with ‹v ≠ ?lv› show False .. qed thus ?thesis by (simp add: v lookup_monom_mult lookup_tail_2 term_simps) next case False thus ?thesis by (simp add: lookup_monom_mult) qed moreover have "lookup (?b (tail q)) v = lookup (?b q) v" proof (cases "?l - t2 adds⇩p v") case True then obtain u where v: "v = (?l - t2) ⊕ u" .. have "u ≠ lt q" proof assume "u = lt q" hence "v = ?lv" by (simp add: v l_2) with ‹v ≠ ?lv› show False .. qed thus ?thesis by (simp add: v lookup_monom_mult lookup_tail_2 term_simps) next case False thus ?thesis by (simp add: lookup_monom_mult) qed ultimately show ?thesis by (simp add: ec spoly_def crit_pair_def lookup_minus t1_def t2_def Let_def lc_def) qed qed next case False show ?thesis by (simp add: spoly_def crit_pair_def False) qed lemma spoly_same: "spoly p p = 0" by (simp add: spoly_def) lemma spoly_swap: "spoly p q = - spoly q p" by (simp add: spoly_def lcs_comm Let_def) lemma spoly_red_zero_imp_crit_pair_cbelow_on: assumes "dickson_grading d" and "F ⊆ dgrad_p_set d m" and "p ∈ dgrad_p_set d m" and "q ∈ dgrad_p_set d m" and "p ≠ 0" and "q ≠ 0" and "(red F)⇧*⇧* (spoly p q) 0" shows "crit_pair_cbelow_on d m F p q" proof - from assms(7) have "relation.cs (red F) (fst (crit_pair p q)) (snd (crit_pair p q))" unfolding spoly_alt[OF assms(5) assms(6)] by (rule red_diff_rtrancl_cs) with assms(1) assms(2) assms(3) assms(4) show ?thesis by (rule crit_pair_cs_imp_crit_pair_cbelow_on) qed lemma dgrad_p_set_le_spoly_zero: "dgrad_p_set_le d {spoly p 0} {p}" proof (simp add: term_simps spoly_def lt_def[of 0] lcs_comm lcs_zero dgrad_p_set_le_def Keys_insert Let_def min_term_def lc_def[symmetric], intro conjI impI dgrad_set_leI) fix s assume "s ∈ pp_of_term ` keys (monom_mult (1 / lc p) 0 p)" then obtain u where "u ∈ keys (monom_mult (1 / lc p) 0 p)" and "s = pp_of_term u" .. from this(1) keys_monom_mult_subset have "u ∈ (⊕) 0 ` keys p" .. hence "u ∈ keys p" by (simp add: image_iff term_simps) hence "s ∈ pp_of_term ` keys p" by (simp add: ‹s = pp_of_term u›) moreover have "d s ≤ d s" .. ultimately show "∃t∈pp_of_term ` keys p. d s ≤ d t" .. qed simp lemma dgrad_p_set_le_spoly: assumes "dickson_grading d" shows "dgrad_p_set_le d {spoly p q} {p, q}" proof (cases "p = 0") case True have "dgrad_p_set_le d {spoly p q} {spoly q 0}" unfolding True spoly_swap[of 0 q] by (fact dgrad_p_set_le_uminus) also have "dgrad_p_set_le d ... {q}" by (fact dgrad_p_set_le_spoly_zero) also have "dgrad_p_set_le d ... {p, q}" by (rule dgrad_p_set_le_subset, simp) finally show ?thesis . next case False show ?thesis proof (cases "q = 0") case True have "dgrad_p_set_le d {spoly p q} {p}" unfolding True by (fact dgrad_p_set_le_spoly_zero) also have "dgrad_p_set_le d ... {p, q}" by (rule dgrad_p_set_le_subset, simp) finally show ?thesis . next case False have "dgrad_p_set_le d {spoly p q} {fst (crit_pair p q), snd (crit_pair p q)}" unfolding spoly_alt[OF ‹p ≠ 0› False] by (rule dgrad_p_set_le_minus) also have "dgrad_p_set_le d ... {p, q}" proof (rule dgrad_p_set_leI_insert) from assms show "dgrad_p_set_le d {fst (crit_pair p q)} {p, q}" by (rule dgrad_p_set_le_fst_crit_pair) next from assms show "dgrad_p_set_le d {snd (crit_pair p q)} {p, q}" by (rule dgrad_p_set_le_snd_crit_pair) qed finally show ?thesis . qed qed lemma dgrad_p_set_closed_spoly: assumes "dickson_grading d" and "p ∈ dgrad_p_set d m" and "q ∈ dgrad_p_set d m" shows "spoly p q ∈ dgrad_p_set d m" proof - from dgrad_p_set_le_spoly[OF assms(1)] have "{spoly p q} ⊆ dgrad_p_set d m" proof (rule dgrad_p_set_le_dgrad_p_set) from assms(2, 3) show "{p, q} ⊆ dgrad_p_set d m" by simp qed thus ?thesis by simp qed lemma components_spoly_subset: "component_of_term ` keys (spoly p q) ⊆ component_of_term ` Keys {p, q}" unfolding spoly_def Let_def proof (split if_split, intro conjI impI) define c where "c = (1 / lookup p (lt p))" define d where "d = (1 / lookup q (lt q))" define s where "s = lcs (lp p) (lp q) - lp p" define t where "t = lcs (lp p) (lp q) - lp q" show "component_of_term ` keys (monom_mult c s p - monom_mult d t q) ⊆ component_of_term ` Keys {p, q}" proof fix k assume "k ∈ component_of_term ` keys (monom_mult c s p - monom_mult d t q)" then obtain v where "v ∈ keys (monom_mult c s p - monom_mult d t q)" and k: "k = component_of_term v" .. from this(1) keys_minus have "v ∈ keys (monom_mult c s p) ∪ keys (monom_mult d t q)" .. thus "k ∈ component_of_term ` Keys {p, q}" proof assume "v ∈ keys (monom_mult c s p)" from this keys_monom_mult_subset have "v ∈ (⊕) s ` keys p" .. then obtain u where "u ∈ keys p" and v: "v = s ⊕ u" .. have "u ∈ Keys {p, q}" by (rule in_KeysI, fact, simp) moreover have "k = component_of_term u" by (simp add: v k term_simps) ultimately show ?thesis by simp next assume "v ∈ keys (monom_mult d t q)" from this keys_monom_mult_subset have "v ∈ (⊕) t ` keys q" .. then obtain u where "u ∈ keys q" and v: "v = t ⊕ u" .. have "u ∈ Keys {p, q}" by (rule in_KeysI, fact, simp) moreover have "k = component_of_term u" by (simp add: v k term_simps) ultimately show ?thesis by simp qed qed qed simp lemma pmdl_closed_spoly: assumes "p ∈ pmdl F" and "q ∈ pmdl F" shows "spoly p q ∈ pmdl F" proof (cases "component_of_term (lt p) = component_of_term (lt q)") case True show ?thesis by (simp add: spoly_def True Let_def, rule pmdl.span_diff, (rule pmdl_closed_monom_mult, fact)+) next case False show ?thesis by (simp add: spoly_def False pmdl.span_zero) qed subsection ‹Buchberger's Theorem› text ‹Before proving the main theorem of Gr\"obner bases theory for S-polynomials, as is usually done in textbooks, we first prove it for critical pairs: a set ‹F› yields a confluent reduction relation if the critical pairs of all ‹p ∈ F› and ‹q ∈ F› can be connected below the least common sum of the leading power-products of ‹p› and ‹q›. The reason why we proceed in this way is that it becomes much easier to prove the correctness of Buchberger's second criterion for avoiding useless pairs.› lemma crit_pair_cbelow_imp_confluent_dgrad_p_set: assumes dg: "dickson_grading d" and "F ⊆ dgrad_p_set d m" assumes main: "⋀p q. p ∈ F ⟹ q ∈ F ⟹ p ≠ 0 ⟹ q ≠ 0 ⟹ crit_pair_cbelow_on d m F p q" shows "relation.is_confluent_on (red F) (dgrad_p_set d m)" proof - let ?A = "dgrad_p_set d m" let ?R = "red F" let ?RS = "λa b. red F a b ∨ red F b a" let ?ord = "(≺⇩p)" from dg have ro: "Confluence.relation_order ?R ?ord ?A" by (rule is_relation_order_red) have dw: "relation.dw_closed ?R ?A" by (rule relation.dw_closedI, rule dgrad_p_set_closed_red, rule dg, rule assms(2)) show ?thesis proof (rule relation_order.loc_connectivity_implies_confluence, fact ro) show "is_loc_connective_on ?A ?ord ?R" unfolding is_loc_connective_on_def proof (intro ballI allI impI) fix a b1 b2 :: "'t ⇒⇩0 'b" assume "a ∈ ?A" assume "?R a b1 ∧ ?R a b2" hence "?R a b1" and "?R a b2" by simp_all hence "b1 ∈ ?A" and "b2 ∈ ?A" and "?ord b1 a" and "?ord b2 a" using red_ord dgrad_p_set_closed_red[OF dg assms(2) ‹a ∈ ?A›] by blast+ from this(1) this(2) have "b1 - b2 ∈ ?A" by (rule dgrad_p_set_closed_minus) from ‹red F a b1› obtain f1 and t1 where "f1 ∈ F" and r1: "red_single a b1 f1 t1" by (rule red_setE) from ‹red F a b2› obtain f2 and t2 where "f2 ∈ F" and r2: "red_single a b2 f2 t2" by (rule red_setE) from r1 r2 have "f1 ≠ 0" and "f2 ≠ 0" by (simp_all add: red_single_def) hence lc1: "lc f1 ≠ 0" and lc2: "lc f2 ≠ 0" using lc_not_0 by auto show "cbelow_on ?A ?ord a (λa b. ?R a b ∨ ?R b a) b1 b2" proof (cases "t1 ⊕ lt f1 = t2 ⊕ lt f2") case False from confluent_distinct[OF r1 r2 False ‹f1 ∈ F› ‹f2 ∈ F›] obtain s where s1: "(red F)⇧*⇧* b1 s" and s2: "(red F)⇧*⇧* b2 s" . have "relation.cs ?R b1 b2" unfolding relation.cs_def by (intro exI conjI, fact s1, fact s2) from ro dw this ‹b1 ∈ ?A› ‹b2 ∈ ?A› ‹?ord b1 a› ‹?ord b2 a› show ?thesis by (rule relation_order.cs_implies_cbelow_on) next case True hence ec: "component_of_term (lt f1) = component_of_term (lt f2)" by (metis component_of_term_splus) let ?l1 = "lp f1" let ?l2 = "lp f2" define v where "v ≡ t2 ⊕ lt f2" define l where "l ≡ lcs ?l1 ?l2" define a' where "a' = except a {v}" define ma where "ma = monomial (lookup a v) v" have v_alt: "v = t1 ⊕ lt f1" by (simp only: True v_def) have "a = ma + a'" unfolding ma_def a'_def by (fact plus_except) have comp_f1: "component_of_term (lt f1) = component_of_term v" by (simp add: v_alt term_simps) have "?l1 adds l" unfolding l_def by (rule adds_lcs) have "?l2 adds l" unfolding l_def by (rule adds_lcs_2) have "?l1 adds⇩p (t1 ⊕ lt f1)" by (simp add: adds_pp_splus term_simps) hence "?l1 adds⇩p v" by (simp add: v_alt) have "?l2 adds⇩p v" by (simp add: v_def adds_pp_splus term_simps) from ‹?l1 adds⇩p v› ‹?l2 adds⇩p v› have "l adds⇩p v" by (simp add: l_def adds_pp_def lcs_adds) have "pp_of_term (v ⊖ ?l1) = t1" by (simp add: v_alt term_simps) with ‹l adds⇩p v› ‹?l1 adds l› have tf1': "pp_of_term ((l - ?l1) ⊕ (v ⊖ l)) = t1" by (simp add: minus_splus_sminus_cancel) hence tf1: "((pp_of_term v) - l) + (l - ?l1) = t1" by (simp add: add.commute term_simps) have "pp_of_term (v ⊖ ?l2) = t2" by (simp add: v_def term_simps) with ‹l adds⇩p v› ‹?l2 adds l› have tf2': "pp_of_term ((l - ?l2) ⊕ (v ⊖ l)) = t2" by (simp add: minus_splus_sminus_cancel) hence tf2: "((pp_of_term v) - l) + (l - ?l2) = t2" by (simp add: add.commute term_simps) let ?ca = "lookup a v" let ?v = "pp_of_term v - l" have "?v + l = pp_of_term v" using ‹l adds⇩p v› adds_minus adds_pp_def by blast from tf1' have "?v adds t1" unfolding pp_of_term_splus add.commute[of "l - ?l1"] pp_of_term_sminus using addsI by blast with dg have "d ?v ≤ d t1" by (rule dickson_grading_adds_imp_le) also from dg ‹a ∈ ?A› r1 have "... ≤ m" by (rule dgrad_p_set_red_single_pp) finally have "d ?v ≤ m" . from r2 have "?ca ≠ 0" by (simp add: red_single_def v_def) hence "- ?ca ≠ 0" by simp (* b1 *) from r1 have "b1 = a - monom_mult (?ca / lc f1) t1 f1" by (simp add: red_single_def v_alt) also have "... = monom_mult (- ?ca) ?v (fst (crit_pair f1 f2)) + a'" proof (simp add: a'_def ec crit_pair_def l_def[symmetric] monom_mult_assoc tf1, rule poly_mapping_eqI, simp add: lookup_add lookup_minus) fix u show "lookup a u - lookup (monom_mult (?ca / lc f1) t1 f1) u = lookup (monom_mult (- (?ca / lc f1)) t1 (tail f1)) u + lookup (except a {v}) u" proof (cases "u = v") case True show ?thesis by (simp add: True lookup_except v_alt lookup_monom_mult lookup_tail_2 lc_def[symmetric] lc1 term_simps) next case False hence "u ∉ {v}" by simp moreover { assume "t1 adds⇩p u" hence "t1 ⊕ (u ⊖ t1) = u" by (simp add: adds_pp_sminus) hence "u ⊖ t1 ≠ lt f1" using False v_alt by auto hence "lookup f1 (u ⊖ t1) = lookup (tail f1) (u ⊖ t1)" by (simp add: lookup_tail_2) } ultimately show ?thesis using False by (simp add: lookup_except lookup_monom_mult) qed qed finally have b1: "b1 = monom_mult (- ?ca) ?v (fst (crit_pair f1 f2)) + a'" . (* b2 *) from r2 have "b2 = a - monom_mult (?ca / lc f2) t2 f2" by (simp add: red_single_def v_def True) also have "... = monom_mult (- ?ca) ?v (snd (crit_pair f1 f2)) + a'" proof (simp add: a'_def ec crit_pair_def l_def[symmetric] monom_mult_assoc tf2, rule poly_mapping_eqI, simp add: lookup_add lookup_minus) fix u show "lookup a u - lookup (monom_mult (?ca / lc f2) t2 f2) u = lookup (monom_mult (- (?ca / lc f2)) t2 (tail f2)) u + lookup (except a {v}) u" proof (cases "u = v") case True show ?thesis by (simp add: True lookup_except v_def lookup_monom_mult lookup_tail_2 lc_def[symmetric] lc2 term_simps) next case False hence "u ∉ {v}" by simp moreover { assume "t2 adds⇩p u" hence "t2 ⊕ (u ⊖ t2) = u" by (simp add: adds_pp_sminus) hence "u ⊖ t2 ≠ lt f2" using False v_def by auto hence "lookup f2 (u ⊖ t2) = lookup (tail f2) (u ⊖ t2)" by (simp add: lookup_tail_2) } ultimately show ?thesis using False by (simp add: lookup_except lookup_monom_mult) qed qed finally have b2: "b2 = monom_mult (- ?ca) ?v (snd (crit_pair f1 f2)) + a'" . let ?lv = "term_of_pair (l, component_of_term (lt f1))" from ‹f1 ∈ F› ‹f2 ∈ F› ‹f1 ≠ 0› ‹f2 ≠ 0› have "crit_pair_cbelow_on d m F f1 f2" by (rule main) hence "cbelow_on ?A ?ord (monomial 1 ?lv) ?RS (fst (crit_pair f1 f2)) (snd (crit_pair f1 f2))" by (simp only: crit_pair_cbelow_on_def l_def) with dg assms (2) ‹d ?v ≤ m› ‹- ?ca ≠ 0› have "cbelow_on ?A ?ord (monom_mult (- ?ca) ?v (monomial 1 ?lv)) ?RS (monom_mult (- ?ca) ?v (fst (crit_pair f1 f2))) (monom_mult (- ?ca) ?v (snd (crit_pair f1 f2)))" by (rule cbelow_on_monom_mult) hence "cbelow_on ?A ?ord (monomial (- ?ca) v) ?RS (monom_mult (- ?ca) ?v (fst (crit_pair f1 f2))) (monom_mult (- ?ca) ?v (snd (crit_pair f1 f2)))" by (simp add: monom_mult_monomial ‹(pp_of_term v - l) + l = pp_of_term v› splus_def comp_f1 term_simps) with ‹?ca ≠ 0› have "cbelow_on ?A ?ord (monomial ?ca (0 ⊕ v)) ?RS (monom_mult (-?ca) ?v (fst (crit_pair f1 f2))) (monom_mult (-?ca) ?v (snd (crit_pair f1 f2)))" by (rule cbelow_on_monom_mult_monomial) hence "cbelow_on ?A ?ord ma ?RS (monom_mult (-?ca) ?v (fst (crit_pair f1 f2))) (monom_mult (-?ca) ?v (snd (crit_pair f1 f2)))" by (simp add: ma_def term_simps) with dg assms(2) _ _ show "cbelow_on ?A ?ord a ?RS b1 b2" unfolding ‹a = ma + a'› b1 b2 proof (rule cbelow_on_plus) show "a' ∈ ?A" by (rule, simp add: a'_def keys_except, erule conjE, intro dgrad_p_setD, rule ‹a ∈ dgrad_p_set d m›) next show "keys a' ∩ keys ma = {}" by (simp add: ma_def a'_def keys_except) qed qed qed qed fact qed corollary crit_pair_cbelow_imp_GB_dgrad_p_set: assumes "dickson_grading d" and "F ⊆ dgrad_p_set d m" assumes "⋀p q. p ∈ F ⟹ q ∈ F ⟹ p ≠ 0 ⟹ q ≠ 0 ⟹ crit_pair_cbelow_on d m F p q" shows "is_Groebner_basis F" unfolding is_Groebner_basis_def proof (rule relation.confluence_implies_ChurchRosser, simp only: relation.is_confluent_def relation.is_confluent_on_def, intro ballI allI impI) fix a b1 b2 assume a: "(red F)⇧*⇧* a b1 ∧ (red F)⇧*⇧* a b2" from assms(2) obtain n where "m ≤ n" and "a ∈ dgrad_p_set d n" and "F ⊆ dgrad_p_set d n" by (rule dgrad_p_set_insert) { fix p q assume "p ∈ F" and "q ∈ F" and "p ≠ 0" and "q ≠ 0" hence "crit_pair_cbelow_on d m F p q" by (rule assms(3)) from this dgrad_p_set_subset[OF ‹m ≤ n›] have "crit_pair_cbelow_on d n F p q" unfolding crit_pair_cbelow_on_def by (rule cbelow_on_mono) } with assms(1) ‹F ⊆ dgrad_p_set d n› have "relation.is_confluent_on (red F) (dgrad_p_set d n)" by (rule crit_pair_cbelow_imp_confluent_dgrad_p_set) from this ‹a ∈ dgrad_p_set d n› have "∀b1 b2. (red F)⇧*⇧* a b1 ∧ (red F)⇧*⇧* a b2 ⟶ relation.cs (red F) b1 b2" unfolding relation.is_confluent_on_def .. with a show "relation.cs (red F) b1 b2" by blast qed corollary Buchberger_criterion_dgrad_p_set: assumes "dickson_grading d" and "F ⊆ dgrad_p_set d m" assumes "⋀p q. p ∈ F ⟹ q ∈ F ⟹ p ≠ 0 ⟹ q ≠ 0 ⟹ p ≠ q ⟹ component_of_term (lt p) = component_of_term (lt q) ⟹ (red F)⇧*⇧* (spoly p q) 0" shows "is_Groebner_basis F" using assms(1) assms(2) proof (rule crit_pair_cbelow_imp_GB_dgrad_p_set) fix p q assume "p ∈ F" and "q ∈ F" and "p ≠ 0" and "q ≠ 0" from this(1, 2) assms(2) have p: "p ∈ dgrad_p_set d m" and q: "q ∈ dgrad_p_set d m" by auto show "crit_pair_cbelow_on d m F p q" proof (cases "p = q") case True from assms(1) q show ?thesis unfolding True by (rule crit_pair_cbelow_same) next case False show ?thesis proof (cases "component_of_term (lt p) = component_of_term (lt q)") case True from assms(1) assms(2) p q ‹p ≠ 0› ‹q ≠ 0› show "crit_pair_cbelow_on d m F p q" proof (rule spoly_red_zero_imp_crit_pair_cbelow_on) from ‹p ∈ F› ‹q ∈ F› ‹p ≠ 0› ‹q ≠ 0› ‹p ≠ q› True show "(red F)⇧*⇧* (spoly p q) 0" by (rule assms(3)) qed next case False thus ?thesis by (rule crit_pair_cbelow_distinct_component) qed qed qed lemmas Buchberger_criterion_finite = Buchberger_criterion_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl] lemma (in ordered_term) GB_imp_zero_reducibility: assumes "is_Groebner_basis G" and "f ∈ pmdl G" shows "(red G)⇧*⇧* f 0" proof - from in_pmdl_srtc[OF ‹f ∈ pmdl G›] ‹is_Groebner_basis G› have "relation.cs (red G) f 0" unfolding is_Groebner_basis_def relation.is_ChurchRosser_def by simp then obtain s where rfs: "(red G)⇧*⇧* f s" and r0s: "(red G)⇧*⇧* 0 s" unfolding relation.cs_def by auto from rtrancl_0[OF r0s] and rfs show ?thesis by simp qed lemma (in ordered_term) GB_imp_reducibility: assumes "is_Groebner_basis G" and "f ≠ 0" and "f ∈ pmdl G" shows "is_red G f" using assms by (meson GB_imp_zero_reducibility is_red_def relation.rtrancl_is_final) lemma is_Groebner_basis_empty: "is_Groebner_basis {}" by (rule Buchberger_criterion_finite, rule, simp) lemma is_Groebner_basis_singleton: "is_Groebner_basis {f}" by (rule Buchberger_criterion_finite, simp, simp add: spoly_same) subsection ‹Buchberger's Criteria for Avoiding Useless Pairs› text ‹Unfortunately, the product criterion is only applicable to scalar polynomials.› lemma (in gd_powerprod) product_criterion: assumes "dickson_grading d" and "F ⊆ punit.dgrad_p_set d m" and "p ∈ F" and "q ∈ F" and "p ≠ 0" and "q ≠ 0" and "gcs (punit.lt p) (punit.lt q) = 0" shows "punit.crit_pair_cbelow_on d m F p q" proof - let ?lt = "punit.lt p" let ?lq = "punit.lt q" let ?l = "lcs ?lt ?lq" define s where "s = punit.monom_mult (- 1 / (punit.lc p * punit.lc q)) 0 (punit.tail p * punit.tail q)" from assms(7) have "?l = ?lt + ?lq" by (metis add_cancel_left_left gcs_plus_lcs) hence "?l - ?lt = ?lq" and "?l - ?lq = ?lt" by simp_all have "(punit.red {q})⇧*⇧* (punit.tail p * (monomial (1 / punit.lc p) (punit.lt q))) (punit.monom_mult (- (1 / punit.lc p) / punit.lc q) 0 (punit.tail p * punit.tail q))" unfolding punit_mult_scalar[symmetric] using ‹q ≠ 0› by (rule punit.red_mult_scalar_lt) moreover have "punit.monom_mult (1 / punit.lc p) (punit.lt q) (punit.tail p) = punit.tail p * (monomial (1 / punit.lc p) (punit.lt q))" by (simp add: times_monomial_left[symmetric]) ultimately have "(punit.red {q})⇧*⇧* (fst (punit.crit_pair p q)) s" by (simp add: punit.crit_pair_def ‹?l - ?lt = ?lq› s_def) moreover from ‹q ∈ F› have "{q} ⊆ F" by simp ultimately have 1: "(punit.red F)⇧*⇧* (fst (punit.crit_pair p q)) s" by (rule punit.red_rtrancl_subset) have "(punit.red {p})⇧*⇧* (punit.tail q * (monomial (1 / punit.lc q) (punit.lt p))) (punit.monom_mult (- (1 / punit.lc q) / punit.lc p) 0 (punit.tail q * punit.tail p))" unfolding punit_mult_scalar[symmetric] using ‹p ≠ 0› by (rule punit.red_mult_scalar_lt) hence "(punit.red {p})⇧*⇧* (snd (punit.crit_pair p q)) s" by (simp add: punit.crit_pair_def ‹?l - ?lq = ?lt› s_def mult.commute flip: times_monomial_left) moreover from ‹p ∈ F› have "{p} ⊆ F" by simp ultimately have 2: "(punit.red F)⇧*⇧* (snd (punit.crit_pair p q)) s" by (rule punit.red_rtrancl_subset) note assms(1) assms(2) moreover from ‹p ∈ F› ‹F ⊆ punit.dgrad_p_set d m› have "p ∈ punit.dgrad_p_set d m" .. moreover from ‹q ∈ F› ‹F ⊆ punit.dgrad_p_set d m› have "q ∈ punit.dgrad_p_set d m" .. moreover from 1 2 have "relation.cs (punit.red F) (fst (punit.crit_pair p q)) (snd (punit.crit_pair p q))" unfolding relation.cs_def by blast ultimately show ?thesis by (rule punit.crit_pair_cs_imp_crit_pair_cbelow_on) qed lemma chain_criterion: assumes "dickson_grading d" and "F ⊆ dgrad_p_set d m" and "p ∈ F" and "q ∈ F" and "p ≠ 0" and "q ≠ 0" and "lp r adds lcs (lp p) (lp q)" and "component_of_term (lt r) = component_of_term (lt p)" and pr: "crit_pair_cbelow_on d m F p r" and rq: "crit_pair_cbelow_on d m F r q" shows "crit_pair_cbelow_on d m F p q" proof (cases "component_of_term (lt p) = component_of_term (lt q)") case True with assms(8) have comp_r: "component_of_term (lt r) = component_of_term (lt q)" by simp let ?A = "dgrad_p_set d m" let ?RS = "λa b. red F a b ∨ red F b a" let ?lt = "lp p" let ?lq = "lp q" let ?lr = "lp r" let ?ltr = "lcs ?lt ?lr" let ?lrq = "lcs ?lr ?lq" let ?ltq = "lcs ?lt ?lq" from ‹p ∈ F› ‹F ⊆ dgrad_p_set d m› have "p ∈ dgrad_p_set d m" .. from this ‹p ≠ 0› have "d ?lt ≤ m" by (rule dgrad_p_setD_lp) from ‹q ∈ F› ‹F ⊆ dgrad_p_set d m› have "q ∈ dgrad_p_set d m" .. from this ‹q ≠ 0› have "d ?lq ≤ m" by (rule dgrad_p_setD_lp) from assms(1) have "d ?ltq ≤ ord_class.max (d ?lt) (d ?lq)" by (rule dickson_grading_lcs) also from ‹d ?lt ≤ m› ‹d ?lq ≤ m› have "... ≤ m" by simp finally have "d ?ltq ≤ m" . from adds_lcs ‹?lr adds ?ltq› have "?ltr adds ?ltq" by (rule lcs_adds) then obtain up where "?ltq = ?ltr + up" .. hence up1: "?ltq - ?lt = up + (?ltr - ?lt)" and up2: "up + (?ltr - ?lr) = ?ltq - ?lr" by (metis add.commute adds_lcs minus_plus, metis add.commute adds_lcs_2 minus_plus) have fst_pq: "fst (crit_pair p q) = monom_mult 1 up (fst (crit_pair p r))" by (simp add: crit_pair_def monom_mult_assoc up1 True comp_r) from assms(1) assms(2) _ _ pr have "cbelow_on ?A (≺⇩p) (monom_mult 1 up (monomial 1 (term_of_pair (?ltr, component_of_term (lt p))))) ?RS (fst (crit_pair p q)) (monom_mult 1 up (snd (crit_pair p r)))" unfolding fst_pq crit_pair_cbelow_on_def proof (rule cbelow_on_monom_mult) from ‹d ?ltq ≤ m› show "d up ≤ m" by (simp add: ‹?ltq = ?ltr + up› dickson_gradingD1[OF assms(1)]) qed simp hence 1: "cbelow_on ?A (≺⇩p) (monomial 1 (term_of_pair (?ltq, component_of_term (lt p)))) ?RS (fst (crit_pair p q)) (monom_mult 1 up (snd (crit_pair p r)))" by (simp add: monom_mult_monomial ‹?ltq = ?ltr + up› add.commute splus_def term_simps) from ‹?lr adds ?ltq› adds_lcs_2 have "?lrq adds ?ltq" by (rule lcs_adds) then obtain uq where "?ltq = ?lrq + uq" .. hence uq1: "?ltq - ?lq = uq + (?lrq - ?lq)" and uq2: "uq + (?lrq - ?lr) = ?ltq - ?lr" by (metis add.commute adds_lcs_2 minus_plus, metis add.commute adds_lcs minus_plus) have eq: "monom_mult 1 uq (fst (crit_pair r q)) = monom_mult 1 up (snd (crit_pair p r))" by (simp add: crit_pair_def monom_mult_assoc up2 uq2 True comp_r) have snd_pq: "snd (crit_pair p q) = monom_mult 1 uq (snd (crit_pair r q))" by (simp add: crit_pair_def monom_mult_assoc uq1 True comp_r) from assms(1) assms(2) _ _ rq have "cbelow_on ?A (≺⇩p) (monom_mult 1 uq (monomial 1 (term_of_pair (?lrq, component_of_term (lt p))))) ?RS (monom_mult 1 uq (fst (crit_pair r q))) (snd (crit_pair p q))" unfolding snd_pq crit_pair_cbelow_on_def assms(8) proof (rule cbelow_on_monom_mult) from ‹d ?ltq ≤ m› show "d uq ≤ m" by (simp add: ‹?ltq = ?lrq + uq› dickson_gradingD1[OF assms(1)]) qed simp hence "cbelow_on ?A (≺⇩p) (monomial 1 (term_of_pair (?ltq, component_of_term (lt p)))) ?RS (monom_mult 1 uq (fst (crit_pair r q))) (snd (crit_pair p q))" by (simp add: monom_mult_monomial ‹?ltq = ?lrq + uq› add.commute splus_def term_simps) hence "cbelow_on ?A (≺⇩p) (monomial 1 (term_of_pair (?ltq, component_of_term (lt p)))) ?RS (monom_mult 1 up (snd (crit_pair p r))) (snd (crit_pair p q))" by (simp only: eq) with 1 show ?thesis unfolding crit_pair_cbelow_on_def by (rule cbelow_on_transitive) next case False thus ?thesis by (rule crit_pair_cbelow_distinct_component) qed subsection ‹Weak and Strong Gr\"obner Bases› lemma ord_p_wf_on: assumes "dickson_grading d" shows "wfp_on (≺⇩p) (dgrad_p_set d m)" proof (rule wfp_onI_min) fix x::"'t ⇒⇩0 'b" and Q assume "x ∈ Q" and "Q ⊆ dgrad_p_set d m" with assms obtain z where "z ∈ Q" and *: "⋀y. y ≺⇩p z ⟹ y ∉ Q" by (rule ord_p_minimum_dgrad_p_set, blast) from this(1) show "∃z∈Q. ∀y∈dgrad_p_set d m. y ≺⇩p z ⟶ y ∉ Q" proof show "∀y∈dgrad_p_set d m. y ≺⇩p z ⟶ y ∉ Q" by (intro ballI impI *) qed qed (* TODO: Collect all "_dgrad_p_set"-facts in a locale? *) lemma is_red_implies_0_red_dgrad_p_set: assumes "dickson_grading d" and "B ⊆ dgrad_p_set d m" assumes "pmdl B ⊆ pmdl A" and "⋀q. q ∈ pmdl A ⟹ q ∈ dgrad_p_set d m ⟹ q ≠ 0 ⟹ is_red B q" and "p ∈ pmdl A" and "p ∈ dgrad_p_set d m" shows "(red B)⇧*⇧* p 0" proof - from ord_p_wf_on[OF assms(1)] assms(6, 5) show ?thesis proof (induction p rule: wfp_on_induct) case (less p) show ?case proof (cases "p = 0") case True thus ?thesis by simp next case False from assms(4)[OF less(3, 1) False] obtain q where redpq: "red B p q" unfolding is_red_alt .. with assms(1) assms(2) less(1) have "q ∈ dgrad_p_set d m" by (rule dgrad_p_set_closed_red) moreover from redpq have "q ≺⇩p p" by (rule red_ord) moreover from ‹pmdl B ⊆ pmdl A› ‹p ∈ pmdl A› ‹red B p q› have "q ∈ pmdl A" by (rule pmdl_closed_red) ultimately have "(red B)⇧*⇧* q 0" by (rule less(2)) show ?thesis by (rule converse_rtranclp_into_rtranclp, rule redpq, fact) qed qed qed lemma is_red_implies_0_red_dgrad_p_set': assumes "dickson_grading d" and "B ⊆ dgrad_p_set d m" assumes "pmdl B ⊆ pmdl A" and "⋀q. q ∈ pmdl A ⟹ q ≠ 0 ⟹ is_red B q" and "p ∈ pmdl A" shows "(red B)⇧*⇧* p 0" proof - from assms(2) obtain n where "m ≤ n" and "p ∈ dgrad_p_set d n" and B: "B ⊆ dgrad_p_set d n" by (rule dgrad_p_set_insert) from ord_p_wf_on[OF assms(1)] this(2) assms(5) show ?thesis proof (induction p rule: wfp_on_induct) case (less p) show ?case proof (cases "p = 0") case True thus ?thesis by simp next case False from assms(4)[OF ‹p ∈ (pmdl A)› False] obtain q where redpq: "red B p q" unfolding is_red_alt .. with assms(1) B ‹p ∈ dgrad_p_set d n› have "q ∈ dgrad_p_set d n" by (rule dgrad_p_set_closed_red) moreover from redpq have "q ≺⇩p p" by (rule red_ord) moreover from ‹pmdl B ⊆ pmdl A› ‹p ∈ pmdl A› ‹red B p q› have "q ∈ pmdl A" by (rule pmdl_closed_red) ultimately have "(red B)⇧*⇧* q 0" by (rule less(2)) show ?thesis by (rule converse_rtranclp_into_rtranclp, rule redpq, fact) qed qed qed lemma pmdl_eqI_adds_lt_dgrad_p_set: fixes G::"('t ⇒⇩0 'b::field) set" assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m" and "B ⊆ dgrad_p_set d m" and "pmdl G ⊆ pmdl B" assumes "⋀f. f ∈ pmdl B ⟹ f ∈ dgrad_p_set d m ⟹ f ≠ 0 ⟹ (∃g ∈ G. g ≠ 0 ∧ lt g adds⇩t lt f)" shows "pmdl G = pmdl B" proof show "pmdl B ⊆ pmdl G" proof (rule pmdl.span_subset_spanI, rule) fix p assume "p ∈ B" hence "p ∈ pmdl B" and "p ∈ dgrad_p_set d m" by (rule pmdl.span_base, rule, intro assms(3)) with assms(1, 2, 4) _ have "(red G)⇧*⇧* p 0" proof (rule is_red_implies_0_red_dgrad_p_set) fix f assume "f ∈ pmdl B" and "f ∈ dgrad_p_set d m" and "f ≠ 0" hence "(∃g ∈ G. g ≠ 0 ∧ lt g adds⇩t lt f)" by (rule assms(5)) then obtain g where "g ∈ G" and "g ≠ 0" and "lt g adds⇩t lt f" by blast thus "is_red G f" using ‹f ≠ 0› is_red_indI1 by blast qed thus "p ∈ pmdl G" by (rule red_rtranclp_0_in_pmdl) qed qed fact lemma pmdl_eqI_adds_lt_dgrad_p_set': fixes G::"('t ⇒⇩0 'b::field) set" assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m" and "pmdl G ⊆ pmdl B" assumes "⋀f. f ∈ pmdl B ⟹ f ≠ 0 ⟹ (∃g ∈ G. g ≠ 0 ∧ lt g adds⇩t lt f)" shows "pmdl G = pmdl B" proof show "pmdl B ⊆ pmdl G" proof fix p assume "p ∈ pmdl B" with assms(1, 2, 3) _ have "(red G)⇧*⇧* p 0" proof (rule is_red_implies_0_red_dgrad_p_set') fix f assume "f ∈ pmdl B" and "f ≠ 0" hence "(∃g ∈ G. g ≠ 0 ∧ lt g adds⇩t lt f)" by (rule assms(4)) then obtain g where "g ∈ G" and "g ≠ 0" and "lt g adds⇩t lt f" by blast thus "is_red G f" using ‹f ≠ 0› is_red_indI1 by blast qed thus "p ∈ pmdl G" by (rule red_rtranclp_0_in_pmdl) qed qed fact lemma GB_implies_unique_nf_dgrad_p_set: assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m" assumes isGB: "is_Groebner_basis G" shows "∃! h. (red G)⇧*⇧* f h ∧ ¬ is_red G h" proof - from assms(1) assms(2) have "wfP (red G)¯¯" by (rule red_wf_dgrad_p_set) then obtain h where ftoh: "(red G)⇧*⇧* f h" and irredh: "relation.is_final (red G) h" by (rule relation.wf_imp_nf_ex) show ?thesis proof from ftoh and irredh show "(red G)⇧*⇧* f h ∧ ¬ is_red G h" by (simp add: is_red_def) next fix h' assume "(red G)⇧*⇧* f h' ∧ ¬ is_red G h'" hence ftoh': "(red G)⇧*⇧* f h'" and irredh': "relation.is_final (red G) h'" by (simp_all add: is_red_def) show "h' = h" proof (rule relation.ChurchRosser_unique_final) from isGB show "relation.is_ChurchRosser (red G)" by (simp only: is_Groebner_basis_def) qed fact+ qed qed lemma translation_property': assumes "p ≠ 0" and red_p_0: "(red F)⇧*⇧* p 0" shows "is_red F (p + q) ∨ is_red F q" proof (rule disjCI) assume not_red: "¬ is_red F q" from red_p_0 ‹p ≠ 0› obtain f where "f ∈ F" and "f ≠ 0" and lt_adds: "lt f adds⇩t lt p" by (rule zero_reducibility_implies_lt_divisibility) show "is_red F (p + q)" proof (cases "q = 0") case True with is_red_indI1[OF ‹f ∈ F› ‹f ≠ 0› ‹p ≠ 0› lt_adds] show ?thesis by simp next case False from not_red is_red_addsI[OF ‹f ∈ F› ‹f ≠ 0› _ lt_adds, of q] have "¬ lt p ∈ (keys q)" by blast hence "lookup q (lt p) = 0" by (simp add: in_keys_iff) with lt_in_keys[OF ‹p ≠ 0›] have "lt p ∈ (keys (p + q))" unfolding in_keys_iff by (simp add: lookup_add) from is_red_addsI[OF ‹f ∈ F› ‹f ≠ 0› this lt_adds] show ?thesis . qed qed lemma translation_property: assumes "p ≠ q" and red_0: "(red F)⇧*⇧* (p - q) 0" shows "is_red F p ∨ is_red F q" proof - from ‹p ≠ q› have "p - q ≠ 0" by simp from translation_property'[OF this red_0, of q] show ?thesis by simp qed lemma weak_GB_is_strong_GB_dgrad_p_set: assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m" assumes "⋀f. f ∈ pmdl G ⟹ f ∈ dgrad_p_set d m ⟹ (red G)⇧*⇧* f 0" shows "is_Groebner_basis G" using assms(1, 2) proof (rule Buchberger_criterion_dgrad_p_set) fix p q assume "p ∈ G" and "q ∈ G" hence "p ∈ pmdl G" and "q ∈ pmdl G" by (auto intro: pmdl.span_base) hence "spoly p q ∈ pmdl G" by (rule pmdl_closed_spoly) thus "(red G)⇧*⇧* (spoly p q) 0" proof (rule assms(3)) note assms(1) moreover from ‹p ∈ G› assms(2) have "p ∈ dgrad_p_set d m" .. moreover from ‹q ∈ G› assms(2) have "q ∈ dgrad_p_set d m" .. ultimately show "spoly p q ∈ dgrad_p_set d m" by (rule dgrad_p_set_closed_spoly) qed qed lemma weak_GB_is_strong_GB: assumes "⋀f. f ∈ (pmdl G) ⟹ (red G)⇧*⇧* f 0" shows "is_Groebner_basis G" unfolding is_Groebner_basis_def proof (rule relation.confluence_implies_ChurchRosser, simp add: relation.is_confluent_def relation.is_confluent_on_def, intro allI impI, erule conjE) fix f p q assume "(red G)⇧*⇧* f p" and "(red G)⇧*⇧* f q" hence "relation.srtc (red G) p q" by (meson relation.rtc_implies_srtc relation.srtc_symmetric relation.srtc_transitive) hence "p - q ∈ pmdl G" by (rule srtc_in_pmdl) hence "(red G)⇧*⇧* (p - q) 0" by (rule assms) thus "relation.cs (red G) p q" by (rule red_diff_rtrancl_cs) qed corollary GB_alt_1_dgrad_p_set: assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m" shows "is_Groebner_basis G ⟷ (∀f ∈ pmdl G. f ∈ dgrad_p_set d m ⟶ (red G)⇧*⇧* f 0)" using weak_GB_is_strong_GB_dgrad_p_set[OF assms] GB_imp_zero_reducibility by blast corollary GB_alt_1: "is_Groebner_basis G ⟷ (∀f ∈ pmdl G. (red G)⇧*⇧* f 0)" using weak_GB_is_strong_GB GB_imp_zero_reducibility by blast lemma isGB_I_is_red: assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m" assumes "⋀f. f ∈ pmdl G ⟹ f ∈ dgrad_p_set d m ⟹ f ≠ 0 ⟹ is_red G f" shows "is_Groebner_basis G" unfolding GB_alt_1_dgrad_p_set[OF assms(1, 2)] proof (intro ballI impI) fix f assume "f ∈ pmdl G" and "f ∈ dgrad_p_set d m" with assms(1, 2) subset_refl assms(3) show "(red G)⇧*⇧* f 0" by (rule is_red_implies_0_red_dgrad_p_set) qed lemma GB_alt_2_dgrad_p_set: assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m" shows "is_Groebner_basis G ⟷ (∀f ∈ pmdl G. f ≠ 0 ⟶ is_red G f)" proof assume "is_Groebner_basis G" show "∀f∈pmdl G. f ≠ 0 ⟶ is_red G f" proof (intro ballI, intro impI) fix f assume "f ∈ (pmdl G)" and "f ≠ 0" show "is_red G f" by (rule GB_imp_reducibility, fact+) qed next assume a2: "∀f∈pmdl G. f ≠ 0 ⟶ is_red G f" show "is_Groebner_basis G" unfolding GB_alt_1 proof fix f assume "f ∈ pmdl G" from assms show "(red G)⇧*⇧* f 0" proof (rule is_red_implies_0_red_dgrad_p_set') fix q assume "q ∈ pmdl G" and "q ≠ 0" thus "is_red G q" by (rule a2[rule_format]) qed (fact subset_refl, fact) qed qed lemma GB_adds_lt: assumes "is_Groebner_basis G" and "f ∈ pmdl G" and "f ≠ 0" obtains g where "g ∈ G" and "g ≠ 0" and "lt g adds⇩t lt f" proof - from assms(1) assms(2) have "(red G)⇧*⇧* f 0" by (rule GB_imp_zero_reducibility) show ?thesis by (rule zero_reducibility_implies_lt_divisibility, fact+) qed lemma isGB_I_adds_lt: assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m" assumes "⋀f. f ∈ pmdl G ⟹ f ∈ dgrad_p_set d m ⟹ f ≠ 0 ⟹ (∃g ∈ G. g ≠ 0 ∧ lt g adds⇩t lt f)" shows "is_Groebner_basis G" using assms(1, 2) proof (rule isGB_I_is_red) fix f assume "f ∈ pmdl G" and "f ∈ dgrad_p_set d m" and "f ≠ 0" hence "(∃g ∈ G. g ≠ 0 ∧ lt g adds⇩t lt f)" by (rule assms(3)) then obtain g where "g ∈ G" and "g ≠ 0" and "lt g adds⇩t lt f" by blast thus "is_red G f" using ‹f ≠ 0› is_red_indI1 by blast qed lemma GB_alt_3_dgrad_p_set: assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m" shows "is_Groebner_basis G ⟷ (∀f ∈ pmdl G. f ≠ 0 ⟶ (∃g ∈ G. g ≠ 0 ∧ lt g adds⇩t lt f))" (is "?L ⟷ ?R") proof assume ?L show ?R proof (intro ballI impI) fix f assume "f ∈ pmdl G" and "f ≠ 0" with ‹?L› obtain g where "g ∈ G" and "g ≠ 0" and "lt g adds⇩t lt f" by (rule GB_adds_lt) thus "∃g∈G. g ≠ 0 ∧ lt g adds⇩t lt f" by blast qed next assume ?R show ?L unfolding GB_alt_2_dgrad_p_set[OF assms] proof (intro ballI impI) fix f assume "f ∈ pmdl G" and "f ≠ 0" with ‹?R› have "(∃g ∈ G. g ≠ 0 ∧ lt g adds⇩t lt f)" by blast then obtain g where "g ∈ G" and "g ≠ 0" and "lt g adds⇩t lt f" by blast thus "is_red G f" using ‹f ≠ 0› is_red_indI1 by blast qed qed lemma GB_insert: assumes "is_Groebner_basis G" and "f ∈ pmdl G" shows "is_Groebner_basis (insert f G)" using assms unfolding GB_alt_1 by (metis insert_subset pmdl.span_insert_idI red_rtrancl_subset subsetI) lemma GB_subset: assumes "is_Groebner_basis G" and "G ⊆ G'" and "pmdl G' = pmdl G" shows "is_Groebner_basis G'" using assms(1) unfolding GB_alt_1 using assms(2) assms(3) red_rtrancl_subset by blast lemma (in ordered_term) GB_remove_0_stable_GB: assumes "is_Groebner_basis G" shows "is_Groebner_basis (G - {0})" using assms by (simp only: is_Groebner_basis_def red_minus_singleton_zero) lemmas is_red_implies_0_red_finite = is_red_implies_0_red_dgrad_p_set'[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl] lemmas GB_implies_unique_nf_finite = GB_implies_unique_nf_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl] lemmas GB_alt_2_finite = GB_alt_2_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl] lemmas GB_alt_3_finite = GB_alt_3_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl] lemmas pmdl_eqI_adds_lt_finite = pmdl_eqI_adds_lt_dgrad_p_set'[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl] subsection ‹Alternative Characterization of Gr\"obner Bases via Representations of S-Polynomials› definition spoly_rep :: "('a ⇒ nat) ⇒ nat ⇒ ('t ⇒⇩0 'b) set ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b::field) ⇒ bool" where "spoly_rep d m G g1 g2 ⟷ (∃q. spoly g1 g2 = (∑g∈G. q g ⊙ g) ∧ (∀g. q g ∈ punit.dgrad_p_set d m ∧ (q g ⊙ g ≠ 0 ⟶ lt (q g ⊙ g) ≺⇩t term_of_pair (lcs (lp g1) (lp g2), component_of_term (lt g2)))))" lemma spoly_repI: "spoly g1 g2 = (∑g∈G. q g ⊙ g) ⟹ (⋀g. q g ∈ punit.dgrad_p_set d m) ⟹ (⋀g. q g ⊙ g ≠ 0 ⟹ lt (q g ⊙ g) ≺⇩t term_of_pair (lcs (lp g1) (lp g2), component_of_term (lt g2))) ⟹ spoly_rep d m G g1 g2" by (auto simp: spoly_rep_def) lemma spoly_repI_zero: assumes "spoly g1 g2 = 0" shows "spoly_rep d m G g1 g2" proof (rule spoly_repI) show "spoly g1 g2 = (∑g∈G. 0 ⊙ g)" by (simp add: assms) qed (simp_all add: punit.zero_in_dgrad_p_set) lemma spoly_repE: assumes "spoly_rep d m G g1 g2" obtains q where "spoly g1 g2 = (∑g∈G. q g ⊙ g)" and "⋀g. q g ∈ punit.dgrad_p_set d m" and "⋀g. q g ⊙ g ≠ 0 ⟹ lt (q g ⊙ g) ≺⇩t term_of_pair (lcs (lp g1) (lp g2), component_of_term (lt g2))" using assms by (auto simp: spoly_rep_def) corollary isGB_D_spoly_rep: assumes "dickson_grading d" and "is_Groebner_basis G" and "G ⊆ dgrad_p_set d m" and "finite G" and "g1 ∈ G" and "g2 ∈ G" and "g1 ≠ 0" and "g2 ≠ 0" shows "spoly_rep d m G g1 g2" proof (cases "spoly g1 g2 = 0") case True thus ?thesis by (rule spoly_repI_zero) next case False let ?v = "term_of_pair (lcs (lp g1) (lp g2), component_of_term (lt g1))" let ?h = "crit_pair g1 g2" from assms(7, 8) have eq: "spoly g1 g2 = fst ?h + (- snd ?h)" by (simp add: spoly_alt) have "fst ?h ≺⇩p monomial 1 ?v" by (fact fst_crit_pair_below_lcs) hence d1: "fst ?h = 0 ∨ lt (fst ?h) ≺⇩t ?v" by (simp only: ord_strict_p_monomial_iff) have "snd ?h ≺⇩p monomial 1 ?v" by (fact snd_crit_pair_below_lcs) hence d2: "snd ?h = 0 ∨ lt (- snd ?h) ≺⇩t ?v" by (simp only: ord_strict_p_monomial_iff lt_uminus) note assms(1) moreover from assms(5, 3) have "g1 ∈ dgrad_p_set d m" .. moreover from assms(6, 3) have "g2 ∈ dgrad_p_set d m" .. ultimately have "spoly g1 g2 ∈ dgrad_p_set d m" by (rule dgrad_p_set_closed_spoly) from assms(5) have "g1 ∈ pmdl G" by (rule pmdl.span_base) moreover from assms(6) have "g2 ∈ pmdl G" by (rule pmdl.span_base) ultimately have "spoly g1 g2 ∈ pmdl G" by (rule pmdl_closed_spoly) with assms(2) have "(red G)⇧*⇧* (spoly g1 g2) 0" by (rule GB_imp_zero_reducibility) with assms(1, 3, 4) ‹spoly _ _ ∈ dgrad_p_set _ _› obtain q where 1: "spoly g1 g2 = 0 + (∑g∈G. q g ⊙ g)" and 2: "⋀g. q g ∈ punit.dgrad_p_set d m" and "⋀g. lt (q g ⊙ g) ≼⇩t lt (spoly g1 g2)" by (rule red_rtrancl_repE) blast show ?thesis proof (rule spoly_repI) fix g note ‹lt (q g ⊙ g) ≼⇩t lt (spoly g1 g2)› also from d1 have "lt (spoly g1 g2) ≺⇩t ?v" proof assume "fst ?h = 0" hence eq: "spoly g1 g2 = - snd ?h" by (simp add: eq) also from d2 have "lt … ≺⇩t ?v" proof assume "snd ?h = 0" with False show ?thesis by (simp add: eq) qed finally show ?thesis . next assume *: "lt (fst ?h) ≺⇩t ?v" from d2 show ?thesis proof assume "snd ?h = 0" with * show ?thesis by (simp add: eq) next assume **: "lt (- snd ?h) ≺⇩t ?v" have "lt (spoly g1 g2) ≼⇩t ord_term_lin.max (lt (fst ?h)) (lt (- snd ?h))" unfolding eq by (fact lt_plus_le_max) also from * ** have "… ≺⇩t ?v" by (simp only: ord_term_lin.max_less_iff_conj) finally show ?thesis . qed qed also from False have "… = term_of_pair (lcs (lp g1) (lp g2), component_of_term (lt g2))" by (simp add: spoly_def Let_def split: if_split_asm) finally show "lt (q g ⊙ g) ≺⇩t term_of_pair (lcs (lp g1) (lp g2), component_of_term (lt g2))" . qed (simp_all add: 1 2) qed text ‹The finiteness assumption on ‹G› in the following theorem could be dropped, but it makes the proof a lot easier (although it is still fairly complicated).› lemma isGB_I_spoly_rep: assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m" and "finite G" and "⋀g1 g2. g1 ∈ G ⟹ g2 ∈ G ⟹ g1 ≠ 0 ⟹ g2 ≠ 0 ⟹ spoly g1 g2 ≠ 0 ⟹ spoly_rep d m G g1 g2" shows "is_Groebner_basis G" proof (rule ccontr) assume "¬ is_Groebner_basis G" then obtain p where "p ∈ pmdl G" and p_in: "p ∈ dgrad_p_set d m" and "¬ (red G)⇧*⇧* p 0" by (auto simp: GB_alt_1_dgrad_p_set[OF assms(1, 2)]) from ‹¬ is_Groebner_basis G› have "G ≠ {}" by (auto simp: is_Groebner_basis_empty) obtain r where p_red: "(red G)⇧*⇧* p r" and r_irred: "¬ is_red G r" proof - define A where "A = {q. (red G)⇧*⇧* p q}" from assms(1, 2) have "wfP (red G)¯¯" by (rule red_wf_dgrad_p_set) moreover have "p ∈ A" by (simp add: A_def) ultimately obtain r where "r ∈ A" and r_min: "⋀z. (red G)¯¯ z r ⟹ z ∉ A" by (rule wfE_min[to_pred]) blast show ?thesis proof from ‹r ∈ A› show *: "(red G)⇧*⇧* p r" by (simp add: A_def) show "¬ is_red G r" proof assume "is_red G r" then obtain z where "(red G) r z" by (rule is_redE) hence "(red G)¯¯ z r" by simp hence "z ∉ A" by (rule r_min) hence "¬ (red G)⇧*⇧* p z" by (simp add: A_def) moreover from * ‹(red G) r z› have "(red G)⇧*⇧* p z" .. ultimately show False .. qed qed qed from assms(1, 2) p_in p_red have r_in: "r ∈ dgrad_p_set d m" by (rule dgrad_p_set_closed_red_rtrancl) from p_red ‹¬ (red G)⇧*⇧* p 0› have "r ≠ 0" by blast from p_red have "p - r ∈ pmdl G" by (rule red_rtranclp_diff_in_pmdl) with ‹p ∈ pmdl G› have "p - (p - r) ∈ pmdl G" by (rule pmdl.span_diff) hence "r ∈ pmdl G" by simp with assms(3) obtain q0 where r: "r = (∑g∈G. q0 g ⊙ g)" by (rule pmdl.span_finiteE) from assms(3) have "finite (q0 ` G)" by (rule finite_imageI) then obtain m0 where "q0 ` G ⊆ punit.dgrad_p_set d m0" by (rule punit.dgrad_p_set_exhaust) define m' where "m' = ord_class.max m m0" have "dgrad_p_set d m ⊆ dgrad_p_set d m'" by (rule dgrad_p_set_subset) (simp add: m'_def) with assms(2) have G_sub: "G ⊆ dgrad_p_set d m'" by (rule subset_trans) have "punit.dgrad_p_set d m0 ⊆ punit.dgrad_p_set d m'" by (rule punit.dgrad_p_set_subset) (simp add: m'_def) with ‹q0 ` G ⊆ _› have "q0 ` G ⊆ punit.dgrad_p_set d m'" by (rule subset_trans) define mlt where "mlt = (λq. ord_term_lin.Max (lt ` {q g ⊙ g | g. g ∈ G ∧ q g ⊙ g ≠ 0}))" define mnum where "mnum = (λq. card {g∈G. q g ⊙ g ≠ 0 ∧ lt (q g ⊙ g) = mlt q})" define rel where "rel = (λq1 q2. mlt q1 ≺⇩t mlt q2 ∨ (mlt q1 = mlt q2 ∧ mnum q1 < mnum q2))" define rel_dom where "rel_dom = {q. q ` G ⊆ punit.dgrad_p_set d m' ∧ r = (∑g∈G. q g ⊙ g)}" have mlt_in: "mlt q ∈ lt ` {q g ⊙ g | g. g ∈ G ∧ q g ⊙ g ≠ 0}" if "q ∈ rel_dom" for q unfolding mlt_def proof (rule ord_term_lin.Max_in, simp_all add: assms(3), rule ccontr) assume "∄g. g ∈ G ∧ q g ⊙ g ≠ 0" hence "q g ⊙ g = 0" if "g ∈ G" for g using that by simp with that have "r = 0" by (simp add: rel_dom_def) with ‹r ≠ 0› show False .. qed have rel_dom_dgrad_set: "pp_of_term ` mlt ` rel_dom ⊆ dgrad_set d m'" proof (rule subsetI, elim imageE) fix q v t assume "q ∈ rel_dom" and v: "v = mlt q" and t: "t = pp_of_term v" from this(1) have "v ∈ lt ` {q g ⊙ g | g. g ∈ G ∧ q g ⊙ g ≠ 0}" unfolding v by (rule mlt_in) then obtain g where "g ∈ G" and "q g ⊙ g ≠ 0" and v: "v = lt (q g ⊙ g)" by blast from this(2) have "q g ≠ 0" and "g ≠ 0" by auto hence "v = punit.lt (q g) ⊕ lt g" unfolding v by (rule lt_mult_scalar) hence "t = punit.lt (q g) + lp g" by (simp add: t pp_of_term_splus) also from assms(1) have "d … = ord_class.max (d (punit.lt (q g))) (d (lp g))" by (rule dickson_gradingD1) also have "… ≤ m'" proof (rule max.boundedI) from ‹g ∈ G› ‹q ∈ rel_dom› have "q g ∈ punit.dgrad_p_set d m'" by (auto simp: rel_dom_def) moreover from ‹q g ≠ 0› have "punit.lt (q g) ∈ keys (q g)" by (rule punit.lt_in_keys) ultimately show "d (punit.lt (q g)) ≤ m'" by (rule punit.dgrad_p_setD[simplified]) next from ‹g ∈ G› G_sub have "g ∈ dgrad_p_set d m'" .. moreover from ‹g ≠ 0› have "lt g ∈ keys g" by (rule lt_in_keys) ultimately show "d (lp g) ≤ m'" by (rule dgrad_p_setD) qed finally show "t ∈ dgrad_set d m'" by (simp add: dgrad_set_def) qed obtain q where "q ∈ rel_dom" and q_min: "⋀q'. rel q' q ⟹ q' ∉ rel_dom" proof - from ‹q0 ` G ⊆ punit.dgrad_p_set d m'› have "q0 ∈ rel_dom" by (simp add: rel_dom_def r) hence "mlt q0 ∈ mlt ` rel_dom" by (rule imageI) with assms(1) obtain u where "u ∈ mlt ` rel_dom" and u_min: "⋀w. w ≺⇩t u ⟹ w ∉ mlt ` rel_dom" using rel_dom_dgrad_set by (rule ord_term_minimum_dgrad_set) blast from this(1) obtain q' where "q' ∈ rel_dom" and u: "u = mlt q'" .. hence "q' ∈ rel_dom ∩ {q. mlt q = u}" (is "_ ∈ ?A") by simp hence "mnum q' ∈ mnum ` ?A" by (rule imageI) with wf[to_pred] obtain k where "k ∈ mnum ` ?A" and k_min: "⋀l. l < k ⟹ l ∉ mnum ` ?A" by (rule wfE_min[to_pred]) blast from this(1) obtain q'' where "q'' ∈ rel_dom" and mlt'': "mlt q'' = u" and k: "k = mnum q''" by blast from this(1) show ?thesis proof fix q0 assume "rel q0 q''" show "q0 ∉ rel_dom" proof assume "q0 ∈ rel_dom" from ‹rel q0 q''› show False unfolding rel_def proof (elim disjE conjE) assume "mlt q0 ≺⇩t mlt q''" hence "mlt q0 ∉ mlt ` rel_dom" unfolding mlt'' by (rule u_min) moreover from ‹q0 ∈ rel_dom› have "mlt q0 ∈ mlt ` rel_dom" by (rule imageI) ultimately show ?thesis .. next assume "mlt q0 = mlt q''" with ‹q0 ∈ rel_dom› have "q0 ∈ ?A" by (simp add: mlt'') assume "mnum q0 < mnum q''" hence "mnum q0 ∉ mnum ` ?A" unfolding k[symmetric] by (rule k_min) with ‹q0 ∈ ?A› show ?thesis by blast qed qed qed qed from this(1) have q_in: "⋀g. g ∈ G ⟹ q g ∈ punit.dgrad_p_set d m'" and r: "r = (∑g∈G. q g ⊙ g)" by (auto simp: rel_dom_def) define v where "v = mlt q" from ‹q ∈ rel_dom› have "v ∈ lt ` {q g ⊙ g | g. g ∈ G ∧ q g ⊙ g ≠ 0}" unfolding v_def by (rule mlt_in) then obtain g1 where "g1 ∈ G" and "q g1 ⊙ g1 ≠ 0" and v1: "v = lt (q g1 ⊙ g1)" by blast moreover define M where "M = {g∈G. q g ⊙ g ≠ 0 ∧ lt (q g ⊙ g) = v}" ultimately have "g1 ∈ M" by simp have v_max: "lt (q g ⊙ g) ≺⇩t v" if "g ∈ G" and "g ∉ M" and "q g ⊙ g ≠ 0" for g proof - from that have "lt (q g ⊙ g) ≠ v" by (auto simp: M_def) moreover have "lt (q g ⊙ g) ≼⇩t v" unfolding v_def mlt_def by (rule ord_term_lin.Max_ge) (auto simp: assms(3) ‹q g ⊙ g ≠ 0› intro!: imageI ‹g ∈ G›) ultimately show ?thesis by simp qed from ‹q g1 ⊙ g1 ≠ 0› have "q g1 ≠ 0" and "g1 ≠ 0" by auto hence v1': "v = punit.lt (q g1) ⊕ lt g1" unfolding v1 by (rule lt_mult_scalar) have "M - {g1} ≠ {}" proof assume "M - {g1} = {}" have "v ∈ keys (q g1 ⊙ g1)" unfolding v1 using ‹q g1 ⊙ g1 ≠ 0› by (rule lt_in_keys) moreover have "v ∉ keys (∑g∈G-{g1}. q g ⊙ g)" proof assume "v ∈ keys (∑g∈G-{g1}. q g ⊙ g)" also have "… ⊆ (⋃g∈G-{g1}. keys (q g ⊙ g))" by (fact keys_sum_subset) finally obtain g where "g ∈ G - {g1}" and "v ∈ keys (q g ⊙ g)" .. from this(2) have "q g ⊙ g ≠ 0" and "v ≼⇩t lt (q g ⊙ g)" by (auto intro: lt_max_keys) from ‹g ∈ G - {g1}› ‹M - {g1} = {}› have "g ∈ G" and "g ∉ M" by blast+ hence "lt (q g ⊙ g) ≺⇩t v" by (rule v_max) fact with ‹v ≼⇩t _› show False by simp qed ultimately have "v ∈ keys (q g1 ⊙ g1 + (∑g∈G-{g1}. q g ⊙ g))" by (rule in_keys_plusI1) also from ‹g1 ∈ G› assms(3) have "… = keys r" by (simp add: r sum.remove) finally have "v ∈ keys r" . with ‹g1 ∈ G› ‹g1 ≠ 0› have "is_red G r" by (rule is_red_addsI) (simp add: v1' term_simps) with r_irred show False .. qed then obtain g2 where "g2 ∈ M" and "g1 ≠ g2" by blast from this(1) have "g2 ∈ G" and "q g2 ⊙ g2 ≠ 0" and v2: "v = lt (q g2 ⊙ g2)" by (simp_all add: M_def) from this(2) have "q g2 ≠ 0" and "g2 ≠ 0" by auto hence v2': "v = punit.lt (q g2) ⊕ lt g2" unfolding v2 by (rule lt_mult_scalar) hence "component_of_term (punit.lt (q g1) ⊕ lt g1) = component_of_term (punit.lt (q g2) ⊕ lt g2)" by (simp only: v1' flip: v2') hence cmp_eq: "component_of_term (lt g1) = component_of_term (lt g2)" by (simp add: term_simps) have "M ⊆ G" by (simp add: M_def) have "r = q g1 ⊙ g1 + (∑g∈G - {g1}. q g ⊙ g)" using assms(3) ‹g1 ∈ G› by (simp add: r sum.remove) also have "… = q g1 ⊙ g1 + q g2 ⊙ g2 + (∑g∈G - {g1} - {g2}. q g ⊙ g)" using assms(3) ‹g2 ∈ G› ‹g1 ≠ g2› by (metis (no_types, lifting) add.assoc finite_Diff insert_Diff insert_Diff_single insert_iff sum.insert_remove) finally have r: "r = q g1 ⊙ g1 + q g2 ⊙ g2 + (∑g∈G - {g1, g2}. q g ⊙ g)" by (simp flip: Diff_insert2) let ?l = "lcs (lp g1) (lp g2)" let ?v = "term_of_pair (?l, component_of_term (lt g2))" have "lp g1 adds lp (q g1 ⊙ g1)" by (simp add: v1' pp_of_term_splus flip: v1) moreover have "lp g2 adds lp (q g1 ⊙ g1)" by (simp add: v2' pp_of_term_splus flip: v1) ultimately have l_adds: "?l adds lp (q g1 ⊙ g1)" by (rule lcs_adds) have "spoly_rep d m G g1 g2" proof (cases "spoly g1 g2 = 0") case True thus ?thesis by (rule spoly_repI_zero) next case False with ‹g1 ∈ G› ‹g2 ∈ G› ‹g1 ≠ 0› ‹g2 ≠ 0› show ?thesis by (rule assms(4)) qed then obtain q' where spoly: "spoly g1 g2 = (∑g∈G. q' g ⊙ g)" and "⋀g. q' g ∈ punit.dgrad_p_set d m" and "⋀g. q' g ⊙ g ≠ 0 ⟹ lt (q' g ⊙ g) ≺⇩t ?v" by (rule spoly_repE) blast note this(2) also have "punit.dgrad_p_set d m ⊆ punit.dgrad_p_set d m'" by (rule punit.dgrad_p_set_subset) (simp add: m'_def) finally have q'_in: "⋀g. q' g ∈ punit.dgrad_p_set d m'" . define mu where "mu = monomial (lc (q g1 ⊙ g1)) (lp (q g1 ⊙ g1) - ?l)" define mu1 where "mu1 = monomial (1 / lc g1) (?l - lp g1)" define mu2 where "mu2 = monomial (1 / lc g2) (?l - lp g2)" define q'' where "q'' = (λg. q g + mu * q' g) (g1:=punit.tail (q g1) + mu * q' g1, g2:=q g2 + mu * q' g2 + mu * mu2)" from ‹q g1 ⊙ g1 ≠ 0› have "mu ≠ 0" by (simp add: mu_def monomial_0_iff lc_eq_zero_iff) from ‹g1 ≠ 0› l_adds have mu_times_mu1: "mu * mu1 = monomial (punit.lc (q g1)) (punit.lt (q g1))" by (simp add: mu_def mu1_def times_monomial_monomial lc_mult_scalar lc_eq_zero_iff minus_plus_minus_cancel adds_lcs v1' pp_of_term_splus flip: v1) from l_adds have mu_times_mu2: "mu * mu2 = monomial (lc (q g1 ⊙ g1) / lc g2) (punit.lt (q g2))" by (simp add: mu_def mu2_def times_monomial_monomial lc_mult_scalar minus_plus_minus_cancel adds_lcs_2 v2' pp_of_term_splus flip: v1) have "mu1 ⊙ g1 - mu2 ⊙ g2 = spoly g1 g2" by (simp add: spoly_def Let_def cmp_eq lc_def mult_scalar_monomial mu1_def mu2_def) also have "… = q' g1 ⊙ g1 + (∑g∈G - {g1}. q' g ⊙ g)" using assms(3) ‹g1 ∈ G› by (simp add: spoly sum.remove) also have "… = q' g1 ⊙ g1 + q' g2 ⊙ g2 + (∑g∈G - {g1} - {g2}. q' g ⊙ g)" using assms(3) ‹g2 ∈ G› ‹g1 ≠ g2› by (metis (no_types, lifting) add.assoc finite_Diff insert_Diff insert_Diff_single insert_iff sum.insert_remove) finally have "(q' g1 - mu1) ⊙ g1 + (q' g2 + mu2) ⊙ g2 + (∑g∈G - {g1, g2}. q' g ⊙ g) = 0" by (simp add: algebra_simps flip: Diff_insert2) hence "0 = mu ⊙ ((q' g1 - mu1) ⊙ g1 + (q' g2 + mu2) ⊙ g2 + (∑g∈G - {g1, g2}. q' g ⊙ g))" by simp also have "… = (mu * q' g1 - mu * mu1) ⊙ g1 + (mu * q' g2 + mu * mu2) ⊙ g2 + (∑g∈G - {g1, g2}. (mu * q' g) ⊙ g)" by (simp add: mult_scalar_distrib_left sum_mult_scalar_distrib_left distrib_left right_diff_distrib flip: mult_scalar_assoc) finally have "r = r + (mu * q' g1 - mu * mu1) ⊙ g1 + (mu * q' g2 + mu * mu2) ⊙ g2 + (∑g∈G - {g1, g2}. (mu * q' g) ⊙ g)" by simp also have "… = (q g1 - mu * mu1 + mu * q' g1) ⊙ g1 + (q g2 + mu * q' g2 + mu * mu2) ⊙ g2 + (∑g∈G - {g1, g2}. (q g + mu * q' g) ⊙ g)" by (simp add: r algebra_simps flip: sum.distrib) also have "q g1 - mu * mu1 = punit.tail (q g1)" by (simp only: mu_times_mu1 punit.leading_monomial_tail diff_eq_eq add.commute[of "punit.tail (q g1)"]) finally have "r = q'' g1 ⊙ g1 + q'' g2 ⊙ g2 + (∑g∈G - {g1} - {g2}. q'' g ⊙ g)" using ‹g1 ≠ g2› by (simp add: q''_def flip: Diff_insert2) also from ‹finite G› ‹g1 ≠ g2› ‹g1 ∈ G› ‹g2 ∈ G› have "… = (∑g∈G. q'' g ⊙ g)" by (simp add: sum.remove) (metis (no_types, lifting) finite_Diff insert_Diff insert_iff sum.remove) finally have r: "r = (∑g∈G. q'' g ⊙ g)" . have 1: "lt ((mu * q' g) ⊙ g) ≺⇩t v" if "(mu * q' g) ⊙ g ≠ 0" for g proof - from that have "q' g ⊙ g ≠ 0" by (auto simp: mult_scalar_assoc) hence *: "lt (q' g ⊙ g) ≺⇩t ?v" by fact from ‹q' g ⊙ g ≠ 0› ‹mu ≠ 0› have "lt ((mu * q' g) ⊙ g) = (lp (q g1 ⊙ g1) - ?l) ⊕ lt (q' g ⊙ g)" by (simp add: mult_scalar_assoc lt_mult_scalar) (simp add: mu_def punit.lt_monomial monomial_0_iff) also from * have "… ≺⇩t (lp (q g1 ⊙ g1) - ?l) ⊕ ?v" by (rule splus_mono_strict) also from l_adds have "… = v" by (simp add: splus_def minus_plus term_simps v1' flip: cmp_eq v1) finally show ?thesis . qed have 2: "lt (q'' g1 ⊙ g1) ≺⇩t v" if "q'' g1 ⊙ g1 ≠ 0" using that proof (rule lt_less) fix u assume "v ≼⇩t u" have "u ∉ keys (q'' g1 ⊙ g1)" proof assume "u ∈ keys (q'' g1 ⊙ g1)" also from ‹g1 ≠ g2› have "… = keys ((punit.tail (q g1) + mu * q' g1) ⊙ g1)" by (simp add: q''_def) also have "… ⊆ keys (punit.tail (q g1) ⊙ g1) ∪ keys ((mu * q' g1) ⊙ g1)" unfolding mult_scalar_distrib_right by (fact Poly_Mapping.keys_add) finally show False proof assume "u ∈ keys (punit.tail (q g1) ⊙ g1)" hence "u ≼⇩t lt (punit.tail (q g1) ⊙ g1)" by (rule lt_max_keys) also have "… ≼⇩t punit.lt (punit.tail (q g1)) ⊕ lt g1" by (metis in_keys_mult_scalar_le lt_def lt_in_keys min_term_min) also have "… ≺⇩t punit.lt (q g1) ⊕ lt g1" proof (intro splus_mono_strict_left punit.lt_tail notI) assume "punit.tail (q g1) = 0" with ‹u ∈ keys (punit.tail (q g1) ⊙ g1)› show False by simp qed also have "… = v" by (simp only: v1') finally show ?thesis using ‹v ≼⇩t u› by simp next assume "u ∈ keys ((mu * q' g1) ⊙ g1)" hence "(mu * q' g1) ⊙ g1 ≠ 0" and "u ≼⇩t lt ((mu * q' g1) ⊙ g1)" by (auto intro: lt_max_keys) note this(2) also from ‹(mu * q' g1) ⊙ g1 ≠ 0› have "lt ((mu * q' g1) ⊙ g1) ≺⇩t v" by (rule 1) finally show ?thesis using ‹v ≼⇩t u› by simp qed qed thus "lookup (q'' g1 ⊙ g1) u = 0" by (simp add: in_keys_iff) qed have 3: "lt (q'' g2 ⊙ g2) ≼⇩t v" proof (rule lt_le) fix u assume "v ≺⇩t u" have "u ∉ keys (q'' g2 ⊙ g2)" proof assume "u ∈ keys (q'' g2 ⊙ g2)" also have "… = keys ((q g2 + mu * q' g2 + mu * mu2) ⊙ g2)" by (simp add: q''_def) also have "… ⊆ keys (q g2 ⊙ g2 + (mu * q' g2) ⊙ g2) ∪ keys ((mu * mu2) ⊙ g2)" unfolding mult_scalar_distrib_right by (fact Poly_Mapping.keys_add) finally show False proof assume "u ∈ keys (q g2 ⊙ g2 + (mu * q' g2) ⊙ g2)" also have "… ⊆ keys (q g2 ⊙ g2) ∪ keys ((mu * q' g2) ⊙ g2)" by (fact Poly_Mapping.keys_add) finally show ?thesis proof assume "u ∈ keys (q g2 ⊙ g2)" hence "u ≼⇩t lt (q g2 ⊙ g2)" by (rule lt_max_keys) with ‹v ≺⇩t u› show ?thesis by (simp add: v2) next assume "u ∈ keys ((mu * q' g2) ⊙ g2)" hence "(mu * q' g2) ⊙ g2 ≠ 0" and "u ≼⇩t lt ((mu * q' g2) ⊙ g2)" by (auto intro: lt_max_keys) note this(2) also from ‹(mu * q' g2) ⊙ g2 ≠ 0› have "lt ((mu * q' g2) ⊙ g2) ≺⇩t v" by (rule 1) finally show ?thesis using ‹v ≺⇩t u› by simp qed next assume "u ∈ keys ((mu * mu2) ⊙ g2)" hence "(mu * mu2) ⊙ g2 ≠ 0" and "u ≼⇩t lt ((mu * mu2) ⊙ g2)" by (auto intro: lt_max_keys) from this(1) have "(mu * mu2) ≠ 0" by auto note ‹u ≼⇩t _› also from ‹mu * mu2 ≠ 0› ‹g2 ≠ 0› have "lt ((mu * mu2) ⊙ g2) = punit.lt (q g2) ⊕ lt g2" by (simp add: lt_mult_scalar) (simp add: mu_times_mu2 punit.lt_monomial monomial_0_iff) finally show ?thesis using ‹v ≺⇩t u› by (simp add: v2') qed qed thus "lookup (q'' g2 ⊙ g2) u = 0" by (simp add: in_keys_iff) qed have 4: "lt (q'' g ⊙ g) ≼⇩t v" if "g ∈ M" for g proof (cases "g ∈ {g1, g2}") case True hence "g = g1 ∨ g = g2" by simp thus ?thesis proof assume "g = g1" show ?thesis proof (cases "q'' g1 ⊙ g1 = 0") case True thus ?thesis by (simp add: ‹g = g1› min_term_min) next case False hence "lt (q'' g ⊙ g) ≺⇩t v" unfolding ‹g = g1› by (rule 2) thus ?thesis by simp qed next assume "g = g2" with 3 show ?thesis by simp qed next case False hence q'': "q'' g = q g + mu * q' g" by (simp add: q''_def) show ?thesis proof (rule lt_le) fix u assume "v ≺⇩t u" have "u ∉ keys (q'' g ⊙ g)" proof assume "u ∈ keys (q'' g ⊙ g)" also have "… ⊆ keys (q g ⊙ g) ∪ keys ((mu * q' g) ⊙ g)" unfolding q'' mult_scalar_distrib_right by (fact Poly_Mapping.keys_add) finally show False proof assume "u ∈ keys (q g ⊙ g)" hence "u ≼⇩t lt (q g ⊙ g)" by (rule lt_max_keys) with ‹g ∈ M› ‹v ≺⇩t u› show ?thesis by (simp add: M_def) next assume "u ∈ keys ((mu * q' g) ⊙ g)" hence "(mu * q' g) ⊙ g ≠ 0" and "u ≼⇩t lt ((mu * q' g) ⊙ g)" by (auto intro: lt_max_keys) note this(2) also from ‹(mu * q' g) ⊙ g ≠ 0› have "lt ((mu * q' g) ⊙ g) ≺⇩t v" by (rule 1) finally show ?thesis using ‹v ≺⇩t u› by simp qed qed thus "lookup (q'' g ⊙ g) u = 0" by (simp add: in_keys_iff) qed qed have 5: "lt (q'' g ⊙ g) ≺⇩t v" if "g ∈ G" and "g ∉ M" and "q'' g ⊙ g ≠ 0" for g using that(3) proof (rule lt_less) fix u assume "v ≼⇩t u" from that(2) ‹g1 ∈ M› ‹g2 ∈ M› have "g ≠ g1" and "g ≠ g2" by blast+ hence q'': "q'' g = q g + mu * q' g" by (simp add: q''_def) have "u ∉ keys (q'' g ⊙ g)" proof assume "u ∈ keys (q'' g ⊙ g)" also have "… ⊆ keys (q g ⊙ g) ∪ keys ((mu * q' g) ⊙ g)" unfolding q'' mult_scalar_distrib_right by (fact Poly_Mapping.keys_add) finally show False proof assume "u ∈ keys (q g ⊙ g)" hence "q g ⊙ g ≠ 0" and "u ≼⇩t lt (q g ⊙ g)" by (auto intro: lt_max_keys) note this(2) also from that(1, 2) ‹q g ⊙ g ≠ 0› have "… ≺⇩t v" by (rule v_max) finally show ?thesis using ‹v ≼⇩t u› by simp next assume "u ∈ keys ((mu * q' g) ⊙ g)" hence "(mu * q' g) ⊙ g ≠ 0" and "u ≼⇩t lt ((mu * q' g) ⊙ g)" by (auto intro: lt_max_keys) note this(2) also from ‹(mu * q' g) ⊙ g ≠ 0› have "lt ((mu * q' g) ⊙ g) ≺⇩t v" by (rule 1) finally show ?thesis using ‹v ≼⇩t u› by simp qed qed thus "lookup (q'' g ⊙ g) u = 0" by (simp add: in_keys_iff) qed define u where "u = mlt q''" have u_in: "u ∈ lt ` {q'' g ⊙ g | g. g ∈ G ∧ q'' g ⊙ g ≠ 0}" unfolding u_def mlt_def proof (rule ord_term_lin.Max_in, simp_all add: assms(3), rule ccontr) assume "∄g. g ∈ G ∧ q'' g ⊙ g ≠ 0" hence "q'' g ⊙ g = 0" if "g ∈ G" for g using that by simp hence "r = 0" by (simp add: r) with ‹r ≠ 0› show False .. qed have u_max: "lt (q'' g ⊙ g) ≼⇩t u" if "g ∈ G" for g proof (cases "q'' g ⊙ g = 0") case True thus ?thesis by (simp add: min_term_min) next case False show ?thesis unfolding u_def mlt_def by (rule ord_term_lin.Max_ge) (auto simp: assms(3) False intro!: imageI ‹g ∈ G›) qed have "q'' ∈ rel_dom" proof (simp add: rel_dom_def r, intro subsetI, elim imageE) fix g assume "g ∈ G" from assms(1) l_adds have "d (lp (q g1 ⊙ g1) - ?l) ≤ d (lp (q g1 ⊙ g1))" by (rule dickson_grading_minus) also have "… = d (punit.lt (q g1) + lp g1)" by (simp add: v1' term_simps flip: v1) also from assms(1) have "… = ord_class.max (d (punit.lt (q g1))) (d (lp g1))" by (rule dickson_gradingD1) also have "… ≤ m'" proof (rule max.boundedI) from ‹g1 ∈ G› have "q g1 ∈ punit.dgrad_p_set d m'" by (rule q_in) moreover from ‹q g1 ≠ 0› have "punit.lt (q g1) ∈ keys (q g1)" by (rule punit.lt_in_keys) ultimately show "d (punit.lt (q g1)) ≤ m'" by (rule punit.dgrad_p_setD[simplified]) next from ‹g1 ∈ G› G_sub have "g1 ∈ dgrad_p_set d m'" .. moreover from ‹g1 ≠ 0› have "lt g1 ∈ keys g1" by (rule lt_in_keys) ultimately show "d (lp g1) ≤ m'" by (rule dgrad_p_setD) qed finally have d1: "d (lp (q g1 ⊙ g1) - ?l) ≤ m'" . have "d (?l - lp g2) ≤ ord_class.max (d (lp g2)) (d (lp g1))" unfolding lcs_comm[of "lp g1"] using assms(1) by (rule dickson_grading_lcs_minus) also have "… ≤ m'" proof (rule max.boundedI) from ‹g2 ∈ G› G_sub have "g2 ∈ dgrad_p_set d m'" .. moreover from ‹g2 ≠ 0› have "lt g2 ∈ keys g2" by (rule lt_in_keys) ultimately show "d (lp g2) ≤ m'" by (rule dgrad_p_setD) next from ‹g1 ∈ G› G_sub have "g1 ∈ dgrad_p_set d m'" .. moreover from ‹g1 ≠ 0› have "lt g1 ∈ keys g1" by (rule lt_in_keys) ultimately show "d (lp g1) ≤ m'" by (rule dgrad_p_setD) qed finally have mu2: "mu2 ∈ punit.dgrad_p_set d m'" by (simp add: mu2_def punit.dgrad_p_set_def dgrad_set_def) fix z assume z: "z = q'' g" have "g = g1 ∨ g = g2 ∨ (g ≠ g1 ∧ g ≠ g2)" by blast thus "z ∈ punit.dgrad_p_set d m'" proof (elim disjE conjE) assume "g = g1" with ‹g1 ≠ g2› have "q'' g = punit.tail (q g1) + mu * q' g1" by (simp add: q''_def) also have "… ∈ punit.dgrad_p_set d m'" unfolding mu_def times_monomial_left by (intro punit.dgrad_p_set_closed_plus punit.dgrad_p_set_closed_tail punit.dgrad_p_set_closed_monom_mult d1 assms(1) q_in q'_in ‹g1 ∈ G›) finally show ?thesis by (simp only: z) next assume "g = g2" hence "q'' g = q g2 + mu * q' g2 + mu * mu2" by (simp add: q''_def) also have "… ∈ punit.dgrad_p_set d m'" unfolding mu_def times_monomial_left by (intro punit.dgrad_p_set_closed_plus punit.dgrad_p_set_closed_monom_mult d1 mu2 q_in q'_in assms(1) ‹g2 ∈ G›) finally show ?thesis by (simp only: z) next assume "g ≠ g1" and "g ≠ g2" hence "q'' g = q g + mu * q' g" by (simp add: q''_def) also have "… ∈ punit.dgrad_p_set d m'" unfolding mu_def times_monomial_left by (intro punit.dgrad_p_set_closed_plus punit.dgrad_p_set_closed_monom_mult d1 assms(1) q_in q'_in ‹g ∈ G›) finally show ?thesis by (simp only: z) qed qed with q_min have "¬ rel q'' q" by blast hence "v ≼⇩t u" and "u ≠ v ∨ mnum q ≤ mnum q''" by (auto simp: v_def u_def rel_def) moreover have "u ≼⇩t v" proof - from u_in obtain g where "g ∈ G" and "q'' g ⊙ g ≠ 0" and u: "u = lt (q'' g ⊙ g)" by blast show ?thesis proof (cases "g ∈ M") case True thus ?thesis unfolding u by (rule 4) next case False with ‹g ∈ G› have "lt (q'' g ⊙ g) ≺⇩t v" using ‹q'' g ⊙ g ≠ 0› by (rule 5) thus ?thesis by (simp add: u) qed qed ultimately have u_v: "u = v" and "mnum q ≤ mnum q''" by simp_all note this(2) also have "mnum q'' < card M" unfolding mnum_def proof (rule psubset_card_mono) from ‹M ⊆ G› ‹finite G› show "finite M" by (rule finite_subset) next have "{g∈G. q'' g ⊙ g ≠ 0 ∧ lt (q'' g ⊙ g) = v} ⊆ M - {g1}" proof fix g assume "g ∈ {g∈G. q'' g ⊙ g ≠ 0 ∧ lt (q'' g ⊙ g) = v}" hence "g ∈ G" and "q'' g ⊙ g ≠ 0" and "lt (q'' g ⊙ g) = v" by simp_all with 2 5 show "g ∈ M - {g1}" by blast qed also from ‹g1 ∈ M› have "… ⊂ M" by blast finally show "{g∈G. q'' g ⊙ g ≠ 0 ∧ lt (q'' g ⊙ g) = mlt q''} ⊂ M" by (simp only: u_v flip: u_def) qed also have "… = mnum q" by (simp only: M_def mnum_def v_def) finally show False .. qed subsection ‹Replacing Elements in Gr\"obner Bases› lemma replace_in_dgrad_p_set: assumes "G ⊆ dgrad_p_set d m" obtains n where "q ∈ dgrad_p_set d n" and "G ⊆ dgrad_p_set d n" and "insert q (G - {p}) ⊆ dgrad_p_set d n" proof - from assms obtain n where "m ≤ n" and 1: "q ∈ dgrad_p_set d n" and 2: "G ⊆ dgrad_p_set d n" by (rule dgrad_p_set_insert) from this(2, 3) have "insert q (G - {p}) ⊆ dgrad_p_set d n" by auto with 1 2 show ?thesis .. qed lemma GB_replace_lt_adds_stable_GB_dgrad_p_set: assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m" assumes isGB: "is_Groebner_basis G" and "q ≠ 0" and q: "q ∈ (pmdl G)" and "lt q adds⇩t lt p" shows "is_Groebner_basis (insert q (G - {p}))" (is "is_Groebner_basis ?G'") proof - from assms(2) obtain n where 1: "G ⊆ dgrad_p_set d n" and 2: "?G' ⊆ dgrad_p_set d n" by (rule replace_in_dgrad_p_set) from isGB show ?thesis unfolding GB_alt_3_dgrad_p_set[OF assms(1) 1] GB_alt_3_dgrad_p_set[OF assms(1) 2] proof (intro ballI impI) fix f assume f1: "f ∈ (pmdl ?G')" and "f ≠ 0" and a1: "∀f∈pmdl G. f ≠ 0 ⟶ (∃g∈G. g ≠ 0 ∧ lt g adds⇩t lt f)" from f1 pmdl.replace_span[OF q, of p] have "f ∈ pmdl G" .. from a1[rule_format, OF this ‹f ≠ 0›] obtain g where "g ∈ G" and "g ≠ 0" and "lt g adds⇩t lt f" by auto show "∃g∈?G'. g ≠ 0 ∧ lt g adds⇩t lt f" proof (cases "g = p") case True show ?thesis proof from ‹lt q adds⇩t lt p› have "lt q adds⇩t lt g" unfolding True . also have "... adds⇩t lt f" by fact finally have "lt q adds⇩t lt f" . with ‹q ≠ 0› show "q ≠ 0 ∧ lt q adds⇩t lt f" .. next show "q ∈ ?G'" by simp qed next case False show ?thesis proof show "g ≠ 0 ∧ lt g adds⇩t lt f" by (rule, fact+) next from ‹g ∈ G› False show "g ∈ ?G'" by blast qed qed qed qed lemma GB_replace_lt_adds_stable_pmdl_dgrad_p_set: assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m" assumes isGB: "is_Groebner_basis G" and "q ≠ 0" and "q ∈ pmdl G" and "lt q adds⇩t lt p" shows "pmdl (insert q (G - {p})) = pmdl G" (is "pmdl ?G' = pmdl G") proof (rule, rule pmdl.replace_span, fact, rule) fix f assume "f ∈ pmdl G" note assms(1) moreover from assms(2) obtain n where "?G' ⊆ dgrad_p_set d n" by (rule replace_in_dgrad_p_set) moreover have "is_Groebner_basis ?G'" by (rule GB_replace_lt_adds_stable_GB_dgrad_p_set, fact+) ultimately have "∃! h. (red ?G')⇧*⇧* f h ∧ ¬ is_red ?G' h" by (rule GB_implies_unique_nf_dgrad_p_set) then obtain h where ftoh: "(red ?G')⇧*⇧* f h" and irredh: "¬ is_red ?G' h" by auto have "¬ is_red G h" proof assume "is_red G h" have "is_red ?G' h" by (rule replace_lt_adds_stable_is_red, fact+) with irredh show False .. qed have "f - h ∈ pmdl ?G'" by (rule red_rtranclp_diff_in_pmdl, rule ftoh) have "f - h ∈ pmdl G" by (rule, fact, rule pmdl.replace_span, fact) from pmdl.span_diff[OF this ‹f ∈ pmdl G›] have "-h ∈ pmdl G" by simp from pmdl.span_neg[OF this] have "h ∈ pmdl G" by simp with isGB ‹¬ is_red G h› have "h = 0" using GB_imp_reducibility by auto with ftoh have "(red ?G')⇧*⇧* f 0" by simp thus "f ∈ pmdl ?G'" by (simp add: red_rtranclp_0_in_pmdl) qed lemma GB_replace_red_stable_GB_dgrad_p_set: assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m" assumes isGB: "is_Groebner_basis G" and "p ∈ G" and q: "red (G - {p}) p q" shows "is_Groebner_basis (insert q (G - {p}))" (is "is_Groebner_basis ?G'") proof - from assms(2) obtain n where 1: "G ⊆ dgrad_p_set d n" and 2: "?G' ⊆ dgrad_p_set d n" by (rule replace_in_dgrad_p_set) from isGB show ?thesis unfolding GB_alt_2_dgrad_p_set[OF assms(1) 1] GB_alt_2_dgrad_p_set[OF assms(1) 2] proof (intro ballI impI) fix f assume f1: "f ∈ (pmdl ?G')" and "f ≠ 0" and a1: "∀f∈pmdl G. f ≠ 0 ⟶ is_red G f" have "q ∈ pmdl G" proof (rule pmdl_closed_red, rule pmdl.span_mono) from pmdl.span_superset ‹p ∈ G› show "p ∈ pmdl G" .. next show "G - {p} ⊆ G" by (rule Diff_subset) qed (rule q) from f1 pmdl.replace_span[OF this, of p] have "f ∈ pmdl G" .. have "is_red G f" by (rule a1[rule_format], fact+) show "is_red ?G' f" by (rule replace_red_stable_is_red, fact+) qed qed lemma GB_replace_red_stable_pmdl_dgrad_p_set: assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m" assumes isGB: "is_Groebner_basis G" and "p ∈ G" and ptoq: "red (G - {p}) p q" shows "pmdl (insert q (G - {p})) = pmdl G" (is "pmdl ?G' = _") proof - from ‹p ∈ G› pmdl.span_superset have "p ∈ pmdl G" .. have "q ∈ pmdl G" by (rule pmdl_closed_red, rule pmdl.span_mono, rule Diff_subset, rule ‹p ∈ pmdl G›, rule ptoq) show ?thesis proof (rule, rule pmdl.replace_span, fact, rule) fix f assume "f ∈ pmdl G" note assms(1) moreover from assms(2) obtain n where "?G' ⊆ dgrad_p_set d n" by (rule replace_in_dgrad_p_set) moreover have "is_Groebner_basis ?G'" by (rule GB_replace_red_stable_GB_dgrad_p_set, fact+) ultimately have "∃! h. (red ?G')⇧*⇧* f h ∧ ¬ is_red ?G' h" by (rule GB_implies_unique_nf_dgrad_p_set) then obtain h where ftoh: "(red ?G')⇧*⇧* f h" and irredh: "¬ is_red ?G' h" by auto have "¬ is_red G h" proof assume "is_red G h" have "is_red ?G' h" by (rule replace_red_stable_is_red, fact+) with irredh show False .. qed have "f - h ∈ pmdl ?G'" by (rule red_rtranclp_diff_in_pmdl, rule ftoh) have "f - h ∈ pmdl G" by (rule, fact, rule pmdl.replace_span, fact) from pmdl.span_diff[OF this ‹f ∈ pmdl G›] have "-h ∈ pmdl G" by simp from pmdl.span_neg[OF this] have "h ∈ pmdl G" by simp with isGB ‹¬ is_red G h› have "h = 0" using GB_imp_reducibility by auto with ftoh have "(red ?G')⇧*⇧* f 0" by simp thus "f ∈ pmdl ?G'" by (simp add: red_rtranclp_0_in_pmdl) qed qed lemma GB_replace_red_rtranclp_stable_GB_dgrad_p_set: assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m" assumes isGB: "is_Groebner_basis G" and "p ∈ G" and ptoq: "(red (G - {p}))⇧*⇧* p q" shows "is_Groebner_basis (insert q (G - {p}))" using ptoq proof (induct q rule: rtranclp_induct) case base from isGB ‹p ∈ G› show ?case by (simp add: insert_absorb) next case (step y z) show ?case proof (cases "y = p") case True from assms(1) assms(2) isGB ‹p ∈ G› show ?thesis proof (rule GB_replace_red_stable_GB_dgrad_p_set) from ‹red (G - {p}) y z› show "red (G - {p}) p z" unfolding True . qed next case False show ?thesis proof (cases "y ∈ G") case True with ‹y ≠ p› have "y ∈ G - {p}" (is "_ ∈ ?G'") by blast hence "insert y (G - {p}) = ?G'" by auto with step(3) have "is_Groebner_basis ?G'" by simp from ‹y ∈ ?G'› pmdl.span_superset have "y ∈ pmdl ?G'" .. have "z ∈ pmdl ?G'" by (rule pmdl_closed_red, rule subset_refl, fact+) show "is_Groebner_basis (insert z ?G')" by (rule GB_insert, fact+) next case False from assms(2) obtain n where "insert y (G - {p}) ⊆ dgrad_p_set d n" by (rule replace_in_dgrad_p_set) from assms(1) this step(3) have "is_Groebner_basis (insert z (insert y (G - {p}) - {y}))" proof (rule GB_replace_red_stable_GB_dgrad_p_set) from ‹red (G - {p}) y z› False show "red ((insert y (G - {p})) - {y}) y z" by simp qed simp moreover from False have "... = (insert z (G - {p}))" by simp ultimately show ?thesis by simp qed qed qed lemma GB_replace_red_rtranclp_stable_pmdl_dgrad_p_set: assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m" assumes isGB: "is_Groebner_basis G" and "p ∈ G" and ptoq: "(red (G - {p}))⇧*⇧* p q" shows "pmdl (insert q (G - {p})) = pmdl G" using ptoq proof (induct q rule: rtranclp_induct) case base from ‹p ∈ G› show ?case by (simp add: insert_absorb) next case (step y z) show ?case proof (cases "y = p") case True from assms(1) assms(2) isGB ‹p ∈ G› step(2) show ?thesis unfolding True by (rule GB_replace_red_stable_pmdl_dgrad_p_set) next case False have gb: "is_Groebner_basis (insert y (G - {p}))" by (rule GB_replace_red_rtranclp_stable_GB_dgrad_p_set, fact+) show ?thesis proof (cases "y ∈ G") case True with ‹y ≠ p› have "y ∈ G - {p}" (is "_ ∈ ?G'") by blast hence eq: "insert y ?G' = ?G'" by auto from ‹y ∈ ?G'› have "y ∈ pmdl ?G'" by (rule pmdl.span_base) have "z ∈ pmdl ?G'" by (rule pmdl_closed_red, rule subset_refl, fact+) hence "pmdl (insert z ?G') = pmdl ?G'" by (rule pmdl.span_insert_idI) also from step(3) have "... = pmdl G" by (simp only: eq) finally show ?thesis . next case False from assms(2) obtain n where 1: "insert y (G - {p}) ⊆ dgrad_p_set d n" by (rule replace_in_dgrad_p_set) from False have "pmdl (insert z (G - {p})) = pmdl (insert z (insert y (G - {p}) - {y}))" by auto also from assms(1) 1 gb have "... = pmdl (insert y (G - {p}))" proof (rule GB_replace_red_stable_pmdl_dgrad_p_set) from step(2) False show "red ((insert y (G - {p})) - {y}) y z" by simp qed simp also have "... = pmdl G" by fact finally show ?thesis . qed qed qed lemmas GB_replace_lt_adds_stable_GB_finite = GB_replace_lt_adds_stable_GB_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl] lemmas GB_replace_lt_adds_stable_pmdl_finite = GB_replace_lt_adds_stable_pmdl_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl] lemmas GB_replace_red_stable_GB_finite = GB_replace_red_stable_GB_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl] lemmas GB_replace_red_stable_pmdl_finite = GB_replace_red_stable_pmdl_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl] lemmas GB_replace_red_rtranclp_stable_GB_finite = GB_replace_red_rtranclp_stable_GB_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl] lemmas GB_replace_red_rtranclp_stable_pmdl_finite = GB_replace_red_rtranclp_stable_pmdl_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl] subsection ‹An Inconstructive Proof of the Existence of Finite Gr\"obner Bases› lemma ex_finite_GB_dgrad_p_set: assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m" obtains G where "G ⊆ dgrad_p_set d m" and "finite G" and "is_Groebner_basis G" and "pmdl G = pmdl F" proof - define S where "S = {lt f | f. f ∈ pmdl F ∧ f ∈ dgrad_p_set d m ∧ f ≠ 0}" note assms(1) moreover from _ assms(2) have "finite (component_of_term ` S)" proof (rule finite_subset) have "component_of_term ` S ⊆ component_of_term ` Keys (pmdl F)" by (rule image_mono, rule, auto simp add: S_def intro!: in_KeysI lt_in_keys) thus "component_of_term ` S ⊆ component_of_term ` Keys F" by (simp only: components_pmdl) qed moreover have "pp_of_term ` S ⊆ dgrad_set d m" proof fix s assume "s ∈ pp_of_term ` S" then obtain u where "u ∈ S" and "s = pp_of_term u" .. from this(1) obtain f where "f ∈ pmdl F ∧ f ∈ dgrad_p_set d m ∧ f ≠ 0" and u: "u = lt f" unfolding S_def by blast from this(1) have "f ∈ dgrad_p_set d m" and "f ≠ 0" by simp_all have "u ∈ keys f" unfolding u by (rule lt_in_keys, fact) with ‹f ∈ dgrad_p_set d m› have "d (pp_of_term u) ≤ m" unfolding u by (rule dgrad_p_setD) thus "s ∈ dgrad_set d m" by (simp add: ‹s = pp_of_term u› dgrad_set_def) qed ultimately obtain T where "finite T" and "T ⊆ S" and *: "⋀s. s ∈ S ⟹ (∃t∈T. t adds⇩t s)" by (rule ex_finite_adds_term, blast) define crit where "crit = (λt f. f ∈ pmdl F ∧ f ∈ dgrad_p_set d m ∧ f ≠ 0 ∧ t = lt f)" have ex_crit: "t ∈ T ⟹ (∃f. crit t f)" for t proof - assume "t ∈ T" from this ‹T ⊆ S› have "t ∈ S" .. then obtain f where "f ∈ pmdl F ∧ f ∈ dgrad_p_set d m ∧ f ≠ 0" and "t = lt f" unfolding S_def by blast thus "∃f. crit t f" unfolding crit_def by blast qed define G where "G = (λt. SOME g. crit t g) ` T" have G: "g ∈ G ⟹ g ∈ pmdl F ∧ g ∈ dgrad_p_set d m ∧ g ≠ 0" for g proof - assume "g ∈ G" then obtain t where "t ∈ T" and g: "g = (SOME h. crit t h)" unfolding G_def .. have "crit t g" unfolding g by (rule someI_ex, rule ex_crit, fact) thus "g ∈ pmdl F ∧ g ∈ dgrad_p_set d m ∧ g ≠ 0" by (simp add: crit_def) qed have **: "t ∈ T ⟹ (∃g∈G. lt g = t)" for t proof - assume "t ∈ T" define g where "g = (SOME h. crit t h)" from ‹t ∈ T› have "g ∈ G" unfolding g_def G_def by blast thus "∃g∈G. lt g = t" proof have "crit t g" unfolding g_def by (rule someI_ex, rule ex_crit, fact) thus "lt g = t" by (simp add: crit_def) qed qed have adds: "f ∈ pmdl F ⟹ f ∈ dgrad_p_set d m ⟹ f ≠ 0 ⟹ (∃g∈G. g ≠ 0 ∧ lt g adds⇩t lt f)" for f proof - assume "f ∈ pmdl F" and "f ∈ dgrad_p_set d m" and "f ≠ 0" hence "lt f ∈ S" unfolding S_def by blast hence "∃t∈T. t adds⇩t (lt f)" by (rule *) then obtain t where "t ∈ T" and "t adds⇩t (lt f)" .. from this(1) have "∃g∈G. lt g = t" by (rule **) then obtain g where "g ∈ G" and "lt g = t" .. show "∃g∈G. g ≠ 0 ∧ lt g adds⇩t lt f" proof (intro bexI conjI) from G[OF ‹g ∈ G›] show "g ≠ 0" by (elim conjE) next from ‹t adds⇩t lt f› show "lt g adds⇩t lt f" by (simp only: ‹lt g = t›) qed fact qed have sub1: "pmdl G ⊆ pmdl F" proof (rule pmdl.span_subset_spanI, rule) fix g assume "g ∈ G" from G[OF this] show "g ∈ pmdl F" .. qed have sub2: "G ⊆ dgrad_p_set d m" proof fix g assume "g ∈ G" from G[OF this] show "g ∈ dgrad_p_set d m" by (elim conjE) qed show ?thesis proof from ‹finite T› show "finite G" unfolding G_def .. next from assms(1) sub2 adds show "is_Groebner_basis G" proof (rule isGB_I_adds_lt) fix f assume "f ∈ pmdl G" from this sub1 show "f ∈ pmdl F" .. qed next show "pmdl G = pmdl F" proof show "pmdl F ⊆ pmdl G" proof (rule pmdl.span_subset_spanI, rule) fix f assume "f ∈ F" hence "f ∈ pmdl F" by (rule pmdl.span_base) from ‹f ∈ F› assms(3) have "f ∈ dgrad_p_set d m" .. with assms(1) sub2 sub1 _ ‹f ∈ pmdl F› have "(red G)⇧*⇧* f 0" proof (rule is_red_implies_0_red_dgrad_p_set) fix q assume "q ∈ pmdl F" and "q ∈ dgrad_p_set d m" and "q ≠ 0" hence "(∃g ∈ G. g ≠ 0 ∧ lt g adds⇩t lt q)" by (rule adds) then obtain g where "g ∈ G" and "g ≠ 0" and "lt g adds⇩t lt q" by blast thus "is_red G q" using ‹q ≠ 0› is_red_indI1 by blast qed thus "f ∈ pmdl G" by (rule red_rtranclp_0_in_pmdl) qed qed fact next show "G ⊆ dgrad_p_set d m" proof fix g assume "g ∈ G" hence "g ∈ pmdl F ∧ g ∈ dgrad_p_set d m ∧ g ≠ 0" by (rule G) thus "g ∈ dgrad_p_set d m" by (elim conjE) qed qed qed text ‹The preceding lemma justifies the following definition.› definition some_GB :: "('t ⇒⇩0 'b) set ⇒ ('t ⇒⇩0 'b::field) set" where "some_GB F = (SOME G. finite G ∧ is_Groebner_basis G ∧ pmdl G = pmdl F)" lemma some_GB_props_dgrad_p_set: assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m" shows "finite (some_GB F) ∧ is_Groebner_basis (some_GB F) ∧ pmdl (some_GB F) = pmdl F" proof - from assms obtain G where "finite G" and "is_Groebner_basis G" and "pmdl G = pmdl F" by (rule ex_finite_GB_dgrad_p_set) hence "finite G ∧ is_Groebner_basis G ∧ pmdl G = pmdl F" by simp thus "finite (some_GB F) ∧ is_Groebner_basis (some_GB F) ∧ pmdl (some_GB F) = pmdl F" unfolding some_GB_def by (rule someI) qed lemma finite_some_GB_dgrad_p_set: assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m" shows "finite (some_GB F)" using some_GB_props_dgrad_p_set[OF assms] .. lemma some_GB_isGB_dgrad_p_set: assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m" shows "is_Groebner_basis (some_GB F)" using some_GB_props_dgrad_p_set[OF assms] by (elim conjE) lemma some_GB_pmdl_dgrad_p_set: assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m" shows "pmdl (some_GB F) = pmdl F" using some_GB_props_dgrad_p_set[OF assms] by (elim conjE) lemma finite_imp_finite_component_Keys: assumes "finite F" shows "finite (component_of_term ` Keys F)" by (rule finite_imageI, rule finite_Keys, fact) lemma finite_some_GB_finite: "finite F ⟹ finite (some_GB F)" by (rule finite_some_GB_dgrad_p_set, rule dickson_grading_dgrad_dummy, erule finite_imp_finite_component_Keys, erule dgrad_p_set_exhaust_expl) lemma some_GB_isGB_finite: "finite F ⟹ is_Groebner_basis (some_GB F)" by (rule some_GB_isGB_dgrad_p_set, rule dickson_grading_dgrad_dummy, erule finite_imp_finite_component_Keys, erule dgrad_p_set_exhaust_expl) lemma some_GB_pmdl_finite: "finite F ⟹ pmdl (some_GB F) = pmdl F" by (rule some_GB_pmdl_dgrad_p_set, rule dickson_grading_dgrad_dummy, erule finite_imp_finite_component_Keys, erule dgrad_p_set_exhaust_expl) text ‹Theory ‹Buchberger› implements an algorithm for effectively computing Gr\"obner bases.› subsection ‹Relation ‹red_supset›› text ‹The following relation is needed for proving the termination of Buchberger's algorithm (i.\,e. function ‹gb_schema_aux›).› definition red_supset::"('t ⇒⇩0 'b::field) set ⇒ ('t ⇒⇩0 'b) set ⇒ bool" (infixl "⊐p" 50) where "red_supset A B ≡ (∃p. is_red A p ∧ ¬ is_red B p) ∧ (∀p. is_red B p ⟶ is_red A p)" lemma red_supsetE: assumes "A ⊐p B" obtains p where "is_red A p" and "¬ is_red B p" proof - from assms have "∃p. is_red A p ∧ ¬ is_red B p" by (simp add: red_supset_def) from this obtain p where "is_red A p" and " ¬ is_red B p" by auto thus ?thesis .. qed lemma red_supsetD: assumes a1: "A ⊐p B" and a2: "is_red B p" shows "is_red A p" proof - from assms have "∀p. is_red B p ⟶ is_red A p" by (simp add: red_supset_def) hence "is_red B p ⟶ is_red A p" .. from a2 this show ?thesis by simp qed lemma red_supsetI [intro]: assumes "⋀q. is_red B q ⟹ is_red A q" and "is_red A p" and "¬ is_red B p" shows "A ⊐p B" unfolding red_supset_def using assms by auto lemma red_supset_insertI: assumes "x ≠ 0" and "¬ is_red A x" shows "(insert x A) ⊐p A" proof fix q assume "is_red A q" thus "is_red (insert x A) q" unfolding is_red_alt proof fix a assume "red A q a" from red_unionI2[OF this, of "{x}"] have "red (insert x A) q a" by simp show "∃qa. red (insert x A) q qa" proof show "red (insert x A) q a" by fact qed qed next show "is_red (insert x A) x" unfolding is_red_alt proof from red_unionI1[OF red_self[OF ‹x ≠ 0›], of A] show "red (insert x A) x 0" by simp qed next show "¬ is_red A x" by fact qed lemma red_supset_transitive: assumes "A ⊐p B" and "B ⊐p C" shows "A ⊐p C" proof - from assms(2) obtain p where "is_red B p" and "¬ is_red C p" by (rule red_supsetE) show ?thesis proof fix q assume "is_red C q" with assms(2) have "is_red B q" by (rule red_supsetD) with assms(1) show "is_red A q" by (rule red_supsetD) next from assms(1) ‹is_red B p› show "is_red A p" by (rule red_supsetD) qed fact qed lemma red_supset_wf_on: assumes "dickson_grading d" and "finite K" shows "wfp_on (⊐p) (Pow (dgrad_p_set d m) ∩ {F. component_of_term ` Keys F ⊆ K})" proof (rule wfp_onI_chain, rule, erule exE) let ?A = "dgrad_p_set d m" fix f::"nat ⇒ (('t ⇒⇩0 'b) set)" assume "∀i. f i ∈ Pow ?A ∩ {F. component_of_term ` Keys F ⊆ K} ∧ f (Suc i) ⊐p f i" hence a1_subset: "f i ⊆ ?A" and comp_sub: "component_of_term ` Keys (f i) ⊆ K" and a1: "f (Suc i) ⊐p f i" for i by simp_all have a1_trans: "i < j ⟹ f j ⊐p f i" for i j proof - assume "i < j" thus "f j ⊐p f i" proof (induct j) case 0 thus ?case by simp next case (Suc j) from Suc(2) have "i = j ∨ i < j" by auto thus ?case proof assume "i = j" show ?thesis unfolding ‹i = j› by (fact a1) next assume "i < j" from a1 have "f (Suc j) ⊐p f j" . also from ‹i < j› have "... ⊐p f i" by (rule Suc(1)) finally(red_supset_transitive) show ?thesis . qed qed qed have a2: "∃p ∈ f (Suc i). ∃q. is_red {p} q ∧ ¬ is_red (f i) q" for i proof - from a1 have "f (Suc i) ⊐p f i" . then obtain q where red: "is_red (f (Suc i)) q" and irred: "¬ is_red (f i) q" by (rule red_supsetE) from red obtain p where "p ∈ f (Suc i)" and "is_red {p} q" by (rule is_red_singletonI) show "∃p∈f (Suc i). ∃q. is_red {p} q ∧ ¬ is_red (f i) q" proof show "∃q. is_red {p} q ∧ ¬ is_red (f i) q" proof (intro exI, intro conjI) show "is_red {p} q" by fact qed (fact) next show "p ∈ f (Suc i)" by fact qed qed let ?P = "λi p. p ∈ (f (Suc i)) ∧ (∃q. is_red {p} q ∧ ¬ is_red (f i) q)" define g where "g ≡ λi::nat. (SOME p. ?P i p)" have a3: "?P i (g i)" for i proof - from a2[of i] obtain gi where "gi ∈ f (Suc i)" and "∃q. is_red {gi} q ∧ ¬ is_red (f i) q" .. show ?thesis unfolding g_def by (rule someI[of _ gi], intro conjI, fact+) qed have a4: "i < j ⟹ ¬ lt (g i) adds⇩t (lt (g j))" for i j proof assume "i < j" and adds: "lt (g i) adds⇩t lt (g j)" from a3 have "∃q. is_red {g j} q ∧ ¬ is_red (f j) q" .. then obtain q where redj: "is_red {g j} q" and "¬ is_red (f j) q" by auto have *: "¬ is_red (f (Suc i)) q" proof - from ‹i < j› have "i + 1 < j ∨ i + 1 = j" by auto thus ?thesis proof assume "i + 1 < j" from red_supsetD[OF a1_trans[rule_format, OF this], of q] ‹¬ is_red (f j) q› show ?thesis by auto next assume "i + 1 = j" thus ?thesis using ‹¬ is_red (f j) q› by simp qed qed from a3 have "g i ∈ f (i + 1)" and redi: "∃q. is_red {g i} q ∧ ¬ is_red (f i) q" by simp_all have "¬ is_red {g i} q" proof assume "is_red {g i} q" from is_red_singletonD[OF this ‹g i ∈ f (i + 1)›] * show False by simp qed have "g i ≠ 0" proof - from redi obtain q0 where "is_red {g i} q0" by auto from is_red_singleton_not_0[OF this] show ?thesis . qed from ‹¬ is_red {g i} q› is_red_singleton_trans[OF redj adds ‹g i ≠ 0›] show False by simp qed from _ assms(2) have a5: "finite (component_of_term ` range (lt ∘ g))" proof (rule finite_subset) show "component_of_term ` range (lt ∘ g) ⊆ K" proof (rule, elim imageE, simp) fix i from a3 have "g i ∈ f (Suc i)" and "∃q. is_red {g i} q ∧ ¬ is_red (f i) q" by simp_all from this(2) obtain q where "is_red {g i} q" by auto hence "g i ≠ 0" by (rule is_red_singleton_not_0) hence "lt (g i) ∈ keys (g i)" by (rule lt_in_keys) hence "component_of_term (lt (g i)) ∈ component_of_term ` keys (g i)" by simp also have "... ⊆ component_of_term ` Keys (f (Suc i))" by (rule image_mono, rule keys_subset_Keys, fact) also have "... ⊆ K" by (fact comp_sub) finally show "component_of_term (lt (g i)) ∈ K" . qed qed have a6: "pp_of_term ` range (lt ∘ g) ⊆ dgrad_set d m" proof (rule, elim imageE, simp) fix i from a3 have "g i ∈ f (Suc i)" and "∃q. is_red {g i} q ∧ ¬ is_red (f i) q" by simp_all from this(2) obtain q where "is_red {g i} q" by auto hence "g i ≠ 0" by (rule is_red_singleton_not_0) from a1_subset ‹g i ∈ f (Suc i)› have "g i ∈ ?A" .. from this ‹g i ≠ 0› have "d (lp (g i)) ≤ m" by (rule dgrad_p_setD_lp) thus "lp (g i) ∈ dgrad_set d m" by (rule dgrad_setI) qed from assms(1) a5 a6 obtain i j where "i < j" and "(lt ∘ g) i adds⇩t (lt ∘ g) j" by (rule Dickson_termE) from this a4[OF ‹i < j›] show False by simp qed end (* gd_term *) lemma in_lex_prod_alt: "(x, y) ∈ r <*lex*> s ⟷ (((fst x), (fst y)) ∈ r ∨ (fst x = fst y ∧ ((snd x), (snd y)) ∈ s))" by (metis in_lex_prod prod.collapse prod.inject surj_pair) subsection ‹Context @{locale od_term}› context od_term begin lemmas red_wf = red_wf_dgrad_p_set[OF dickson_grading_zero subset_dgrad_p_set_zero] lemmas Buchberger_criterion = Buchberger_criterion_dgrad_p_set[OF dickson_grading_zero subset_dgrad_p_set_zero] end (* od_term *) end (* theory *)
Theory Algorithm_Schema
(* Author: Alexander Maletzky *) section ‹A General Algorithm Schema for Computing Gr\"obner Bases› theory Algorithm_Schema imports General Groebner_Bases begin text ‹This theory formalizes a general algorithm schema for computing Gr\"obner bases, generalizing Buchberger's original critical-pair/completion algorithm. The algorithm schema depends on several functional parameters that can be instantiated by a variety of concrete functions. Possible instances yield Buchberger's algorithm, Faug\`ere's F4 algorithm, and (as far as we can tell) even his F5 algorithm.› subsection ‹@{term processed}› definition minus_pairs (infixl "-⇩p" 65) where "minus_pairs A B = A - (B ∪ prod.swap ` B)" definition Int_pairs (infixl "∩⇩p" 65) where "Int_pairs A B = A ∩ (B ∪ prod.swap ` B)" definition in_pair (infix "∈⇩p" 50) where "in_pair p A ⟷ (p ∈ A ∪ prod.swap ` A)" definition subset_pairs (infix "⊆⇩p" 50) where "subset_pairs A B ⟷ (∀x. x ∈⇩p A ⟶ x ∈⇩p B)" abbreviation not_in_pair (infix "∉⇩p" 50) where "not_in_pair p A ≡ ¬ p ∈⇩p A" lemma in_pair_alt: "p ∈⇩p A ⟷ (p ∈ A ∨ prod.swap p ∈ A)" by (metis (mono_tags, lifting) UnCI UnE image_iff in_pair_def prod.collapse swap_simp) lemma in_pair_iff: "(a, b) ∈⇩p A ⟷ ((a, b) ∈ A ∨ (b, a) ∈ A)" by (simp add: in_pair_alt) lemma in_pair_minus_pairs [simp]: "p ∈⇩p A -⇩p B ⟷ (p ∈⇩p A ∧ p ∉⇩p B)" by (metis Diff_iff in_pair_def in_pair_iff minus_pairs_def prod.collapse) lemma in_minus_pairs [simp]: "p ∈ A -⇩p B ⟷ (p ∈ A ∧ p ∉⇩p B)" by (metis Diff_iff in_pair_def minus_pairs_def) lemma in_pair_Int_pairs [simp]: "p ∈⇩p A ∩⇩p B ⟷ (p ∈⇩p A ∧ p ∈⇩p B)" by (metis (no_types, hide_lams) Int_iff Int_pairs_def in_pair_alt in_pair_def old.prod.exhaust swap_simp) lemma in_pair_Un [simp]: "p ∈⇩p A ∪ B ⟷ (p ∈⇩p A ∨ p ∈⇩p B)" by (metis (mono_tags, lifting) UnE UnI1 UnI2 image_Un in_pair_def) lemma in_pair_trans [trans]: assumes "p ∈⇩p A" and "A ⊆ B" shows "p ∈⇩p B" using assms by (auto simp: in_pair_def) lemma in_pair_same [simp]: "p ∈⇩p A × A ⟷ p ∈ A × A" by (auto simp: in_pair_def) lemma subset_pairsI [intro]: assumes "⋀x. x ∈⇩p A ⟹ x ∈⇩p B" shows "A ⊆⇩p B" unfolding subset_pairs_def using assms by blast lemma subset_pairsD [trans]: assumes "x ∈⇩p A" and "A ⊆⇩p B" shows "x ∈⇩p B" using assms unfolding subset_pairs_def by blast definition processed :: "('a × 'a) ⇒ 'a list ⇒ ('a × 'a) list ⇒ bool" where "processed p xs ps ⟷ p ∈ set xs × set xs ∧ p ∉⇩p set ps" lemma processed_alt: "processed (a, b) xs ps ⟷ ((a ∈ set xs) ∧ (b ∈ set xs) ∧ (a, b) ∉⇩p set ps)" unfolding processed_def by auto lemma processedI: assumes "a ∈ set xs" and "b ∈ set xs" and "(a, b) ∉⇩p set ps" shows "processed (a, b) xs ps" unfolding processed_alt using assms by simp lemma processedD1: assumes "processed (a, b) xs ps" shows "a ∈ set xs" using assms by (simp add: processed_alt) lemma processedD2: assumes "processed (a, b) xs ps" shows "b ∈ set xs" using assms by (simp add: processed_alt) lemma processedD3: assumes "processed (a, b) xs ps" shows "(a, b) ∉⇩p set ps" using assms by (simp add: processed_alt) lemma processed_Nil: "processed (a, b) xs [] ⟷ (a ∈ set xs ∧ b ∈ set xs)" by (simp add: processed_alt in_pair_iff) lemma processed_Cons: assumes "processed (a, b) xs ps" and a1: "a = p ⟹ b = q ⟹ thesis" and a2: "a = q ⟹ b = p ⟹ thesis" and a3: "processed (a, b) xs ((p, q) # ps) ⟹ thesis" shows thesis proof - from assms(1) have "a ∈ set xs" and "b ∈ set xs" and "(a, b) ∉⇩p set ps" by (simp_all add: processed_alt) show ?thesis proof (cases "(a, b) = (p, q)") case True hence "a = p" and "b = q" by simp_all thus ?thesis by (rule a1) next case False with ‹(a, b) ∉⇩p set ps› have *: "(a, b) ∉ set ((p, q) # ps)" by (auto simp: in_pair_iff) show ?thesis proof (cases "(b, a) = (p, q)") case True hence "a = q" and "b = p" by simp_all thus ?thesis by (rule a2) next case False with ‹(a, b) ∉⇩p set ps› have "(b, a) ∉ set ((p, q) # ps)" by (auto simp: in_pair_iff) with * have "(a, b) ∉⇩p set ((p, q) # ps)" by (simp add: in_pair_iff) with ‹a ∈ set xs› ‹b ∈ set xs› have "processed (a, b) xs ((p, q) # ps)" by (rule processedI) thus ?thesis by (rule a3) qed qed qed lemma processed_minus: assumes "processed (a, b) xs (ps -- qs)" and a1: "(a, b) ∈⇩p set qs ⟹ thesis" and a2: "processed (a, b) xs ps ⟹ thesis" shows thesis proof - from assms(1) have "a ∈ set xs" and "b ∈ set xs" and "(a, b) ∉⇩p set (ps -- qs)" by (simp_all add: processed_alt) show ?thesis proof (cases "(a, b) ∈⇩p set qs") case True thus ?thesis by (rule a1) next case False with ‹(a, b) ∉⇩p set (ps -- qs)› have "(a, b) ∉⇩p set ps" by (auto simp: set_diff_list in_pair_iff) with ‹a ∈ set xs› ‹b ∈ set xs› have "processed (a, b) xs ps" by (rule processedI) thus ?thesis by (rule a2) qed qed subsection ‹Algorithm Schema› subsubsection ‹‹const_lt_component›› context ordered_term begin definition const_lt_component :: "('t ⇒⇩0 'b::zero) ⇒ 'k option" where "const_lt_component p = (let v = lt p in if pp_of_term v = 0 then Some (component_of_term v) else None)" lemma const_lt_component_SomeI: assumes "lp p = 0" and "component_of_term (lt p) = cmp" shows "const_lt_component p = Some cmp" using assms by (simp add: const_lt_component_def) lemma const_lt_component_SomeD1: assumes "const_lt_component p = Some cmp" shows "lp p = 0" using assms by (simp add: const_lt_component_def Let_def split: if_split_asm) lemma const_lt_component_SomeD2: assumes "const_lt_component p = Some cmp" shows "component_of_term (lt p) = cmp" using assms by (simp add: const_lt_component_def Let_def split: if_split_asm) lemma const_lt_component_subset: "const_lt_component ` (B - {0}) - {None} ⊆ Some ` component_of_term ` Keys B" proof fix k assume "k ∈ const_lt_component ` (B - {0}) - {None}" hence "k ∈ const_lt_component ` (B - {0})" and "k ≠ None" by simp_all from this(1) obtain p where "p ∈ B - {0}" and "k = const_lt_component p" .. moreover from ‹k ≠ None› obtain k' where "k = Some k'" by blast ultimately have "const_lt_component p = Some k'" and "p ∈ B" and "p ≠ 0" by simp_all from this(1) have "component_of_term (lt p) = k'" by (rule const_lt_component_SomeD2) moreover have "lt p ∈ Keys B" by (rule in_KeysI, rule lt_in_keys, fact+) ultimately have "k' ∈ component_of_term ` Keys B" by fastforce thus "k ∈ Some ` component_of_term ` Keys B" by (simp add: ‹k = Some k'›) qed corollary card_const_lt_component_le: assumes "finite B" shows "card (const_lt_component ` (B - {0}) - {None}) ≤ card (component_of_term ` Keys B)" proof (rule surj_card_le) show "finite (component_of_term ` Keys B)" by (intro finite_imageI finite_Keys, fact) next show "const_lt_component ` (B - {0}) - {None} ⊆ Some ` component_of_term ` Keys B" by (fact const_lt_component_subset) qed end (* ordered_term *) subsubsection ‹Type synonyms› type_synonym ('a, 'b, 'c) pdata' = "('a ⇒⇩0 'b) × 'c" type_synonym ('a, 'b, 'c) pdata = "('a ⇒⇩0 'b) × nat × 'c" type_synonym ('a, 'b, 'c) pdata_pair = "('a, 'b, 'c) pdata × ('a, 'b, 'c) pdata" type_synonym ('a, 'b, 'c, 'd) selT = "('a, 'b, 'c) pdata list ⇒ ('a, 'b, 'c) pdata list ⇒ ('a, 'b, 'c) pdata_pair list ⇒ nat × 'd ⇒ ('a, 'b, 'c) pdata_pair list" type_synonym ('a, 'b, 'c, 'd) complT = "('a, 'b, 'c) pdata list ⇒ ('a, 'b, 'c) pdata list ⇒ ('a, 'b, 'c) pdata_pair list ⇒ ('a, 'b, 'c) pdata_pair list ⇒ nat × 'd ⇒ (('a, 'b, 'c) pdata' list × 'd)" type_synonym ('a, 'b, 'c, 'd) apT = "('a, 'b, 'c) pdata list ⇒ ('a, 'b, 'c) pdata list ⇒ ('a, 'b, 'c) pdata_pair list ⇒ ('a, 'b, 'c) pdata list ⇒ nat × 'd ⇒ ('a, 'b, 'c) pdata_pair list" type_synonym ('a, 'b, 'c, 'd) abT = "('a, 'b, 'c) pdata list ⇒ ('a, 'b, 'c) pdata list ⇒ ('a, 'b, 'c) pdata list ⇒ nat × 'd ⇒ ('a, 'b, 'c) pdata list" subsubsection ‹Specification of the @{emph ‹selector›} parameter› definition sel_spec :: "('a, 'b, 'c, 'd) selT ⇒ bool" where "sel_spec sel ⟷ (∀gs bs ps data. ps ≠ [] ⟶ (sel gs bs ps data ≠ [] ∧ set (sel gs bs ps data) ⊆ set ps))" lemma sel_specI: assumes "⋀gs bs ps data. ps ≠ [] ⟹ (sel gs bs ps data ≠ [] ∧ set (sel gs bs ps data) ⊆ set ps)" shows "sel_spec sel" unfolding sel_spec_def using assms by blast lemma sel_specD1: assumes "sel_spec sel" and "ps ≠ []" shows "sel gs bs ps data ≠ []" using assms unfolding sel_spec_def by blast lemma sel_specD2: assumes "sel_spec sel" and "ps ≠ []" shows "set (sel gs bs ps data) ⊆ set ps" using assms unfolding sel_spec_def by blast subsubsection ‹Specification of the @{emph ‹add-basis›} parameter› definition ab_spec :: "('a, 'b, 'c, 'd) abT ⇒ bool" where "ab_spec ab ⟷ (∀gs bs ns data. ns ≠ [] ⟶ set (ab gs bs ns data) = set bs ∪ set ns) ∧ (∀gs bs data. ab gs bs [] data = bs)" lemma ab_specI: assumes "⋀gs bs ns data. ns ≠ [] ⟹ set (ab gs bs ns data) = set bs ∪ set ns" and "⋀gs bs data. ab gs bs [] data = bs" shows "ab_spec ab" unfolding ab_spec_def using assms by blast lemma ab_specD1: assumes "ab_spec ab" shows "set (ab gs bs ns data) = set bs ∪ set ns" using assms unfolding ab_spec_def by (metis empty_set sup_bot.right_neutral) lemma ab_specD2: assumes "ab_spec ab" shows "ab gs bs [] data = bs" using assms unfolding ab_spec_def by blast subsubsection ‹Specification of the @{emph ‹add-pairs›} parameter› definition unique_idx :: "('t, 'b, 'c) pdata list ⇒ (nat × 'd) ⇒ bool" where "unique_idx bs data ⟷ (∀f∈set bs. ∀g∈set bs. fst (snd f) = fst (snd g) ⟶ f = g) ∧ (∀f∈set bs. fst (snd f) < fst data)" lemma unique_idxI: assumes "⋀f g. f ∈ set bs ⟹ g ∈ set bs ⟹ fst (snd f) = fst (snd g) ⟹ f = g" and "⋀f. f ∈ set bs ⟹ fst (snd f) < fst data" shows "unique_idx bs data" unfolding unique_idx_def using assms by blast lemma unique_idxD1: assumes "unique_idx bs data" and "f ∈ set bs" and "g ∈ set bs" and "fst (snd f) = fst (snd g)" shows "f = g" using assms unfolding unique_idx_def by blast lemma unique_idxD2: assumes "unique_idx bs data" and "f ∈ set bs" shows "fst (snd f) < fst data" using assms unfolding unique_idx_def by blast lemma unique_idx_Nil: "unique_idx [] data" by (simp add: unique_idx_def) lemma unique_idx_subset: assumes "unique_idx bs data" and "set bs' ⊆ set bs" shows "unique_idx bs' data" proof (rule unique_idxI) fix f g assume "f ∈ set bs'" and "g ∈ set bs'" with assms have "unique_idx bs data" and "f ∈ set bs" and "g ∈ set bs" by auto moreover assume "fst (snd f) = fst (snd g)" ultimately show "f = g" by (rule unique_idxD1) next fix f assume "f ∈ set bs'" with assms(2) have "f ∈ set bs" by auto with assms(1) show "fst (snd f) < fst data" by (rule unique_idxD2) qed context gd_term begin definition ap_spec :: "('t, 'b::field, 'c, 'd) apT ⇒ bool" where "ap_spec ap ⟷ (∀gs bs ps hs data. set (ap gs bs ps hs data) ⊆ set ps ∪ (set hs × (set gs ∪ set bs ∪ set hs)) ∧ (∀B d m. ∀h∈set hs. ∀g∈set gs ∪ set bs ∪ set hs. dickson_grading d ⟶ set gs ∪ set bs ∪ set hs ⊆ B ⟶ fst ` B ⊆ dgrad_p_set d m ⟶ set ps ⊆ set bs × (set gs ∪ set bs) ⟶ unique_idx (gs @ bs @ hs) data ⟶ is_Groebner_basis (fst ` set gs) ⟶ h ≠ g ⟶ fst h ≠ 0 ⟶ fst g ≠ 0 ⟶ (∀a b. (a, b) ∈⇩p set (ap gs bs ps hs data) ⟶ fst a ≠ 0 ⟶ fst b ≠ 0 ⟶ crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)) ⟶ (∀a b. a ∈ set gs ∪ set bs ⟶ b ∈ set gs ∪ set bs ⟶ fst a ≠ 0 ⟶ fst b ≠ 0 ⟶ crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)) ⟶ crit_pair_cbelow_on d m (fst ` B) (fst h) (fst g)) ∧ (∀B d m. ∀h g. dickson_grading d ⟶ set gs ∪ set bs ∪ set hs ⊆ B ⟶ fst ` B ⊆ dgrad_p_set d m ⟶ set ps ⊆ set bs × (set gs ∪ set bs) ⟶ (set gs ∪ set bs) ∩ set hs = {} ⟶ unique_idx (gs @ bs @ hs) data ⟶ is_Groebner_basis (fst ` set gs) ⟶ h ≠ g ⟶ fst h ≠ 0 ⟶ fst g ≠ 0 ⟶ (h, g) ∈ set ps -⇩p set (ap gs bs ps hs data) ⟶ (∀a b. (a, b) ∈⇩p set (ap gs bs ps hs data) ⟶ (a, b) ∈⇩p set hs × (set gs ∪ set bs ∪ set hs) ⟶ fst a ≠ 0 ⟶ fst b ≠ 0 ⟶ crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)) ⟶ crit_pair_cbelow_on d m (fst ` B) (fst h) (fst g)))" text ‹Informally, ‹ap_spec ap› means that, for suitable arguments ‹gs›, ‹bs›, ‹ps› and ‹hs›, the value of ‹ap gs bs ps hs› is a list of pairs ‹ps'› such that for every element ‹(a, b)› missing in ‹ps'› there exists a set of pairs ‹C› by reference to which ‹(a, b)› can be discarded, i.\,e. as soon as all critical pairs of the elements in ‹C› can be connected below some set ‹B›, the same is true for the critical pair of ‹(a, b)›.› lemma ap_specI: assumes "⋀gs bs ps hs data. set (ap gs bs ps hs data) ⊆ set ps ∪ (set hs × (set gs ∪ set bs ∪ set hs))" assumes "⋀gs bs ps hs data B d m h g. dickson_grading d ⟹ set gs ∪ set bs ∪ set hs ⊆ B ⟹ fst ` B ⊆ dgrad_p_set d m ⟹ h ∈ set hs ⟹ g ∈ set gs ∪ set bs ∪ set hs ⟹ set ps ⊆ set bs × (set gs ∪ set bs) ⟹ unique_idx (gs @ bs @ hs) data ⟹ is_Groebner_basis (fst ` set gs) ⟹ h ≠ g ⟹ fst h ≠ 0 ⟹ fst g ≠ 0 ⟹ (⋀a b. (a, b) ∈⇩p set (ap gs bs ps hs data) ⟹ fst a ≠ 0 ⟹ fst b ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)) ⟹ (⋀a b. a ∈ set gs ∪ set bs ⟹ b ∈ set gs ∪ set bs ⟹ fst a ≠ 0 ⟹ fst b ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)) ⟹ crit_pair_cbelow_on d m (fst ` B) (fst h) (fst g)" assumes "⋀gs bs ps hs data B d m h g. dickson_grading d ⟹ set gs ∪ set bs ∪ set hs ⊆ B ⟹ fst ` B ⊆ dgrad_p_set d m ⟹ set ps ⊆ set bs × (set gs ∪ set bs) ⟹ (set gs ∪ set bs) ∩ set hs = {} ⟹ unique_idx (gs @ bs @ hs) data ⟹ is_Groebner_basis (fst ` set gs) ⟹ h ≠ g ⟹ fst h ≠ 0 ⟹ fst g ≠ 0 ⟹ (h, g) ∈ set ps -⇩p set (ap gs bs ps hs data) ⟹ (⋀a b. (a, b) ∈⇩p set (ap gs bs ps hs data) ⟹ (a, b) ∈⇩p set hs × (set gs ∪ set bs ∪ set hs) ⟹ fst a ≠ 0 ⟹ fst b ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)) ⟹ crit_pair_cbelow_on d m (fst ` B) (fst h) (fst g)" shows "ap_spec ap" unfolding ap_spec_def apply (intro allI conjI impI) subgoal by (rule assms(1)) subgoal by (intro ballI impI, rule assms(2), blast+) subgoal by (rule assms(3), blast+) done lemma ap_specD1: assumes "ap_spec ap" shows "set (ap gs bs ps hs data) ⊆ set ps ∪ (set hs × (set gs ∪ set bs ∪ set hs))" using assms unfolding ap_spec_def by (elim allE conjE) (assumption) lemma ap_specD2: assumes "ap_spec ap" and "dickson_grading d" and "set gs ∪ set bs ∪ set hs ⊆ B" and "fst ` B ⊆ dgrad_p_set d m" and "(h, g) ∈⇩p set hs × (set gs ∪ set bs ∪ set hs)" and "set ps ⊆ set bs × (set gs ∪ set bs)" and "unique_idx (gs @ bs @ hs) data" and "is_Groebner_basis (fst ` set gs)" and "h ≠ g" and "fst h ≠ 0" and "fst g ≠ 0" and "⋀a b. (a, b) ∈⇩p set (ap gs bs ps hs data) ⟹ fst a ≠ 0 ⟹ fst b ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)" and "⋀a b. a ∈ set gs ∪ set bs ⟹ b ∈ set gs ∪ set bs ⟹ fst a ≠ 0 ⟹ fst b ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)" shows "crit_pair_cbelow_on d m (fst ` B) (fst h) (fst g)" proof - from assms(5) have "(h, g) ∈ set hs × (set gs ∪ set bs ∪ set hs) ∨ (g, h) ∈ set hs × (set gs ∪ set bs ∪ set hs)" by (simp only: in_pair_iff) thus ?thesis proof assume "(h, g) ∈ set hs × (set gs ∪ set bs ∪ set hs)" hence "h ∈ set hs" and "g ∈ set gs ∪ set bs ∪ set hs" by simp_all from assms(1)[unfolded ap_spec_def, rule_format, of gs bs ps hs data] assms(2-4) this assms (6-) show ?thesis by metis next assume "(g, h) ∈ set hs × (set gs ∪ set bs ∪ set hs)" hence "g ∈ set hs" and "h ∈ set gs ∪ set bs ∪ set hs" by simp_all hence "crit_pair_cbelow_on d m (fst ` B) (fst g) (fst h)" using assms(1)[unfolded ap_spec_def, rule_format, of gs bs ps hs data] assms(2,3,4,6,7,8,10,11,12,13) assms(9)[symmetric] by metis thus ?thesis by (rule crit_pair_cbelow_sym) qed qed lemma ap_specD3: assumes "ap_spec ap" and "dickson_grading d" and "set gs ∪ set bs ∪ set hs ⊆ B" and "fst ` B ⊆ dgrad_p_set d m" and "set ps ⊆ set bs × (set gs ∪ set bs)" and "(set gs ∪ set bs) ∩ set hs = {}" and "unique_idx (gs @ bs @ hs) data" and "is_Groebner_basis (fst ` set gs)" and "h ≠ g" and "fst h ≠ 0" and "fst g ≠ 0" and "(h, g) ∈⇩p set ps -⇩p set (ap gs bs ps hs data)" and "⋀a b. a ∈ set hs ⟹ b ∈ set gs ∪ set bs ∪ set hs ⟹ (a, b) ∈⇩p set (ap gs bs ps hs data) ⟹ fst a ≠ 0 ⟹ fst b ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)" shows "crit_pair_cbelow_on d m (fst ` B) (fst h) (fst g)" proof - have *: "crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)" if 1: "(a, b) ∈⇩p set (ap gs bs ps hs data)" and 2: "(a, b) ∈⇩p set hs × (set gs ∪ set bs ∪ set hs)" and 3: "fst a ≠ 0" and 4: "fst b ≠ 0" for a b proof - from 2 have "(a, b) ∈ set hs × (set gs ∪ set bs ∪ set hs) ∨ (b, a) ∈ set hs × (set gs ∪ set bs ∪ set hs)" by (simp only: in_pair_iff) thus ?thesis proof assume "(a, b) ∈ set hs × (set gs ∪ set bs ∪ set hs)" hence "a ∈ set hs" and "b ∈ set gs ∪ set bs ∪ set hs" by simp_all thus ?thesis using 1 3 4 by (rule assms(13)) next assume "(b, a) ∈ set hs × (set gs ∪ set bs ∪ set hs)" hence "b ∈ set hs" and "a ∈ set gs ∪ set bs ∪ set hs" by simp_all moreover from 1 have "(b, a) ∈⇩p set (ap gs bs ps hs data)" by (auto simp: in_pair_iff) ultimately have "crit_pair_cbelow_on d m (fst ` B) (fst b) (fst a)" using 4 3 by (rule assms(13)) thus ?thesis by (rule crit_pair_cbelow_sym) qed qed from assms(12) have "(h, g) ∈ set ps -⇩p set (ap gs bs ps hs data) ∨ (g, h) ∈ set ps -⇩p set (ap gs bs ps hs data)" by (simp only: in_pair_iff) thus ?thesis proof assume "(h, g) ∈ set ps -⇩p set (ap gs bs ps hs data)" with assms(1)[unfolded ap_spec_def, rule_format, of gs bs ps hs data] assms(2-11) show ?thesis using assms(10) * by metis next assume "(g, h) ∈ set ps -⇩p set (ap gs bs ps hs data)" with assms(1)[unfolded ap_spec_def, rule_format, of gs bs ps hs data] assms(2-11) have "crit_pair_cbelow_on d m (fst ` B) (fst g) (fst h)" using assms(10) * by metis thus ?thesis by (rule crit_pair_cbelow_sym) qed qed lemma ap_spec_Nil_subset: assumes "ap_spec ap" shows "set (ap gs bs ps [] data) ⊆ set ps" using ap_specD1[OF assms] by fastforce lemma ap_spec_fst_subset: assumes "ap_spec ap" shows "fst ` set (ap gs bs ps hs data) ⊆ fst ` set ps ∪ set hs" proof - from ap_specD1[OF assms] have "fst ` set (ap gs bs ps hs data) ⊆ fst ` (set ps ∪ set hs × (set gs ∪ set bs ∪ set hs))" by (rule image_mono) thus ?thesis by auto qed lemma ap_spec_snd_subset: assumes "ap_spec ap" shows "snd ` set (ap gs bs ps hs data) ⊆ snd ` set ps ∪ set gs ∪ set bs ∪ set hs" proof - from ap_specD1[OF assms] have "snd ` set (ap gs bs ps hs data) ⊆ snd ` (set ps ∪ set hs × (set gs ∪ set bs ∪ set hs))" by (rule image_mono) thus ?thesis by auto qed lemma ap_spec_inE: assumes "ap_spec ap" and "(p, q) ∈ set (ap gs bs ps hs data)" assumes 1: "(p, q) ∈ set ps ⟹ thesis" assumes 2: "p ∈ set hs ⟹ q ∈ set gs ∪ set bs ∪ set hs ⟹ thesis" shows thesis proof - from assms(2) ap_specD1[OF assms(1)] have "(p, q) ∈ set ps ∪ set hs × (set gs ∪ set bs ∪ set hs)" .. thus ?thesis proof assume "(p, q) ∈ set ps" thus ?thesis by (rule 1) next assume "(p, q) ∈ set hs × (set gs ∪ set bs ∪ set hs)" hence "p ∈ set hs" and "q ∈ set gs ∪ set bs ∪ set hs" by blast+ thus ?thesis by (rule 2) qed qed lemma subset_Times_ap: assumes "ap_spec ap" and "ab_spec ab" and "set ps ⊆ set bs × (set gs ∪ set bs)" shows "set (ap gs bs (ps -- sps) hs data) ⊆ set (ab gs bs hs data) × (set gs ∪ set (ab gs bs hs data))" proof fix p q assume "(p, q) ∈ set (ap gs bs (ps -- sps) hs data)" with assms(1) show "(p, q) ∈ set (ab gs bs hs data) × (set gs ∪ set (ab gs bs hs data))" proof (rule ap_spec_inE) assume "(p, q) ∈ set (ps -- sps)" hence "(p, q) ∈ set ps" by (simp add: set_diff_list) from this assms(3) have "(p, q) ∈ set bs × (set gs ∪ set bs)" .. hence "p ∈ set bs" and "q ∈ set gs ∪ set bs" by blast+ thus ?thesis by (auto simp add: ab_specD1[OF assms(2)]) next assume "p ∈ set hs" and "q ∈ set gs ∪ set bs ∪ set hs" thus ?thesis by (simp add: ab_specD1[OF assms(2)]) qed qed subsubsection ‹Function ‹args_to_set›› definition args_to_set :: "('t, 'b::field, 'c) pdata list × ('t, 'b, 'c) pdata list × ('t, 'b, 'c) pdata_pair list ⇒ ('t ⇒⇩0 'b) set" where "args_to_set x = fst ` (set (fst x) ∪ set (fst (snd x)) ∪ fst ` set (snd (snd x)) ∪ snd ` set (snd (snd x)))" lemma args_to_set_alt: "args_to_set (gs, bs, ps) = fst ` set gs ∪ fst ` set bs ∪ fst ` fst ` set ps ∪ fst ` snd ` set ps" by (simp add: args_to_set_def image_Un) lemma args_to_set_subset_Times: assumes "set ps ⊆ set bs × (set gs ∪ set bs)" shows "args_to_set (gs, bs, ps) = fst ` set gs ∪ fst ` set bs" unfolding args_to_set_alt using assms by auto lemma args_to_set_subset: assumes "ap_spec ap" and "ab_spec ab" shows "args_to_set (gs, ab gs bs hs data, ap gs bs ps hs data) ⊆ fst ` (set gs ∪ set bs ∪ fst ` set ps ∪ snd ` set ps ∪ set hs)" (is "?l ⊆ fst ` ?r") proof (simp only: args_to_set_alt Un_subset_iff, intro conjI image_mono) show "set (ab gs bs hs data) ⊆ ?r" by (auto simp add: ab_specD1[OF assms(2)]) next from assms(1) have "fst ` set (ap gs bs ps hs data) ⊆ fst ` set ps ∪ set hs" by (rule ap_spec_fst_subset) thus "fst ` set (ap gs bs ps hs data) ⊆ ?r" by blast next from assms(1) have "snd ` set (ap gs bs ps hs data) ⊆ snd ` set ps ∪ set gs ∪ set bs ∪ set hs" by (rule ap_spec_snd_subset) thus "snd ` set (ap gs bs ps hs data) ⊆ ?r" by blast qed blast lemma args_to_set_alt2: assumes "ap_spec ap" and "ab_spec ab" and "set ps ⊆ set bs × (set gs ∪ set bs)" shows "args_to_set (gs, ab gs bs hs data, ap gs bs (ps -- sps) hs data) = fst ` (set gs ∪ set bs ∪ set hs)" (is "?l = fst ` ?r") proof from assms(1, 2) have "?l ⊆ fst ` (set gs ∪ set bs ∪ fst ` set (ps -- sps) ∪ snd ` set (ps -- sps) ∪ set hs)" by (rule args_to_set_subset) also have "... ⊆ fst ` ?r" proof (rule image_mono) have "set gs ∪ set bs ∪ fst ` set (ps -- sps) ∪ snd ` set (ps -- sps) ∪ set hs ⊆ set gs ∪ set bs ∪ fst ` set ps ∪ snd ` set ps ∪ set hs" by (auto simp: set_diff_list) also from assms(3) have "... ⊆ ?r" by fastforce finally show "set gs ∪ set bs ∪ fst ` set (ps -- sps) ∪ snd ` set (ps -- sps) ∪ set hs ⊆ ?r" . qed finally show "?l ⊆ fst ` ?r" . next from assms(2) have eq: "set (ab gs bs hs data) = set bs ∪ set hs" by (rule ab_specD1) have "fst ` ?r ⊆ fst ` set gs ∪ fst ` set (ab gs bs hs data)" unfolding eq using assms(3) by fastforce also have "... ⊆ ?l" unfolding args_to_set_alt by fastforce finally show "fst ` ?r ⊆ ?l" . qed lemma args_to_set_subset1: assumes "set gs1 ⊆ set gs2" shows "args_to_set (gs1, bs, ps) ⊆ args_to_set (gs2, bs, ps)" using assms by (auto simp add: args_to_set_alt) lemma args_to_set_subset2: assumes "set bs1 ⊆ set bs2" shows "args_to_set (gs, bs1, ps) ⊆ args_to_set (gs, bs2, ps)" using assms by (auto simp add: args_to_set_alt) lemma args_to_set_subset3: assumes "set ps1 ⊆ set ps2" shows "args_to_set (gs, bs, ps1) ⊆ args_to_set (gs, bs, ps2)" using assms unfolding args_to_set_alt by blast subsubsection ‹Functions ‹count_const_lt_components›, ‹count_rem_comps› and ‹full_gb›› definition rem_comps_spec :: "('t, 'b::zero, 'c) pdata list ⇒ nat × 'd ⇒ bool" where "rem_comps_spec bs data ⟷ (card (component_of_term ` Keys (fst ` set bs)) = fst data + card (const_lt_component ` (fst ` set bs - {0}) - {None}))" definition count_const_lt_components :: "('t, 'b::zero, 'c) pdata' list ⇒ nat" where "count_const_lt_components hs = length (remdups (filter (λx. x ≠ None) (map (const_lt_component ∘ fst) hs)))" definition count_rem_components :: "('t, 'b::zero, 'c) pdata' list ⇒ nat" where "count_rem_components bs = length (remdups (map component_of_term (Keys_to_list (map fst bs)))) - count_const_lt_components [b←bs . fst b ≠ 0]" lemma count_const_lt_components_alt: "count_const_lt_components hs = card (const_lt_component ` fst ` set hs - {None})" by (simp add: count_const_lt_components_def card_set[symmetric] set_diff_eq image_comp del: not_None_eq) lemma count_rem_components_alt: "count_rem_components bs + card (const_lt_component ` (fst ` set bs - {0}) - {None}) = card (component_of_term ` Keys (fst ` set bs))" proof - have eq: "fst ` {x ∈ set bs. fst x ≠ 0} = fst ` set bs - {0}" by fastforce have "card (const_lt_component ` (fst ` set bs - {0}) - {None}) ≤ card (component_of_term ` Keys (fst ` set bs))" by (rule card_const_lt_component_le, rule finite_imageI, fact finite_set) thus ?thesis by (simp add: count_rem_components_def card_set[symmetric] set_Keys_to_list count_const_lt_components_alt eq) qed lemma rem_comps_spec_count_rem_components: "rem_comps_spec bs (count_rem_components bs, data)" by (simp only: rem_comps_spec_def fst_conv count_rem_components_alt) definition full_gb :: "('t, 'b, 'c) pdata list ⇒ ('t, 'b::zero_neq_one, 'c::default) pdata list" where "full_gb bs = map (λk. (monomial 1 (term_of_pair (0, k)), 0, default)) (remdups (map component_of_term (Keys_to_list (map fst bs))))" lemma fst_set_full_gb: "fst ` set (full_gb bs) = (λv. monomial 1 (term_of_pair (0, component_of_term v))) ` Keys (fst ` set bs)" by (simp add: full_gb_def set_Keys_to_list image_comp) lemma Keys_full_gb: "Keys (fst ` set (full_gb bs)) = (λv. term_of_pair (0, component_of_term v)) ` Keys (fst ` set bs)" by (auto simp add: fst_set_full_gb Keys_def image_image) lemma pps_full_gb: "pp_of_term ` Keys (fst ` set (full_gb bs)) ⊆ {0}" by (simp add: Keys_full_gb image_comp image_subset_iff term_simps) lemma components_full_gb: "component_of_term ` Keys (fst ` set (full_gb bs)) = component_of_term ` Keys (fst ` set bs)" by (simp add: Keys_full_gb image_comp, rule image_cong, fact refl, simp add: term_simps) lemma full_gb_is_full_pmdl: "is_full_pmdl (fst ` set (full_gb bs))" for bs::"('t, 'b::field, 'c::default) pdata list" proof (rule is_full_pmdlI_lt_finite) from finite_set show "finite (fst ` set (full_gb bs))" by (rule finite_imageI) next fix k assume "k ∈ component_of_term ` Keys (fst ` set (full_gb bs))" then obtain v where "v ∈ Keys (fst ` set (full_gb bs))" and k: "k = component_of_term v" .. from this(1) obtain b where "b ∈ fst ` set (full_gb bs)" and "v ∈ keys b" by (rule in_KeysE) from this(1) obtain u where "u ∈ Keys (fst ` set bs)" and b: "b = monomial 1 (term_of_pair (0, component_of_term u))" unfolding fst_set_full_gb .. have lt: "lt b = term_of_pair (0, component_of_term u)" by (simp add: b lt_monomial) from ‹v ∈ keys b› have v: "v = term_of_pair (0, component_of_term u)" by (simp add: b) show "∃b∈fst ` set (full_gb bs). b ≠ 0 ∧ component_of_term (lt b) = k ∧ lp b = 0" proof (intro bexI conjI) show "b ≠ 0" by (simp add: b monomial_0_iff) next show "component_of_term (lt b) = k" by (simp add: lt term_simps k v) next show "lp b = 0" by (simp add: lt term_simps) qed fact qed text ‹In fact, @{thm full_gb_is_full_pmdl} also holds if @{typ 'b} is no field.› lemma full_gb_isGB: "is_Groebner_basis (fst ` set (full_gb bs))" proof (rule Buchberger_criterion_finite) from finite_set show "finite (fst ` set (full_gb bs))" by (rule finite_imageI) next fix p q :: "'t ⇒⇩0 'b" assume "p ∈ fst ` set (full_gb bs)" then obtain v where p: "p = monomial 1 (term_of_pair (0, component_of_term v))" unfolding fst_set_full_gb .. hence lt: "component_of_term (lt p) = component_of_term v" by (simp add: lt_monomial term_simps) assume "q ∈ fst ` set (full_gb bs)" then obtain u where q: "q = monomial 1 (term_of_pair (0, component_of_term u))" unfolding fst_set_full_gb .. hence lq: "component_of_term (lt q) = component_of_term u" by (simp add: lt_monomial term_simps) assume "component_of_term (lt p) = component_of_term (lt q)" hence "component_of_term v = component_of_term u" by (simp only: lt lq) hence "p = q" by (simp only: p q) moreover assume "p ≠ q" ultimately show "(red (fst ` set (full_gb bs)))⇧*⇧* (spoly p q) 0" by (simp only:) qed subsubsection ‹Specification of the @{emph ‹completion›} parameter› definition compl_struct :: "('t, 'b::field, 'c, 'd) complT ⇒ bool" where "compl_struct compl ⟷ (∀gs bs ps sps data. sps ≠ [] ⟶ set sps ⊆ set ps ⟶ (∀d. dickson_grading d ⟶ dgrad_p_set_le d (fst ` (set (fst (compl gs bs (ps -- sps) sps data)))) (args_to_set (gs, bs, ps))) ∧ component_of_term ` Keys (fst ` (set (fst (compl gs bs (ps -- sps) sps data)))) ⊆ component_of_term ` Keys (args_to_set (gs, bs, ps)) ∧ 0 ∉ fst ` set (fst (compl gs bs (ps -- sps) sps data)) ∧ (∀h∈set (fst (compl gs bs (ps -- sps) sps data)). ∀b∈set gs ∪ set bs. fst b ≠ 0 ⟶ ¬ lt (fst b) adds⇩t lt (fst h)))" lemma compl_structI: assumes "⋀d gs bs ps sps data. dickson_grading d ⟹ sps ≠ [] ⟹ set sps ⊆ set ps ⟹ dgrad_p_set_le d (fst ` (set (fst (compl gs bs (ps -- sps) sps data)))) (args_to_set (gs, bs, ps))" assumes "⋀gs bs ps sps data. sps ≠ [] ⟹ set sps ⊆ set ps ⟹ component_of_term ` Keys (fst ` (set (fst (compl gs bs (ps -- sps) sps data)))) ⊆ component_of_term ` Keys (args_to_set (gs, bs, ps))" assumes "⋀gs bs ps sps data. sps ≠ [] ⟹ set sps ⊆ set ps ⟹ 0 ∉ fst ` set (fst (compl gs bs (ps -- sps) sps data))" assumes "⋀gs bs ps sps h b data. sps ≠ [] ⟹ set sps ⊆ set ps ⟹ h ∈ set (fst (compl gs bs (ps -- sps) sps data)) ⟹ b ∈ set gs ∪ set bs ⟹ fst b ≠ 0 ⟹ ¬ lt (fst b) adds⇩t lt (fst h)" shows "compl_struct compl" unfolding compl_struct_def using assms by auto lemma compl_structD1: assumes "compl_struct compl" and "dickson_grading d" and "sps ≠ []" and "set sps ⊆ set ps" shows "dgrad_p_set_le d (fst ` (set (fst (compl gs bs (ps -- sps) sps data)))) (args_to_set (gs, bs, ps))" using assms unfolding compl_struct_def by blast lemma compl_structD2: assumes "compl_struct compl" and "sps ≠ []" and "set sps ⊆ set ps" shows "component_of_term ` Keys (fst ` (set (fst (compl gs bs (ps -- sps) sps data)))) ⊆ component_of_term ` Keys (args_to_set (gs, bs, ps))" using assms unfolding compl_struct_def by blast lemma compl_structD3: assumes "compl_struct compl" and "sps ≠ []" and "set sps ⊆ set ps" shows "0 ∉ fst ` set (fst (compl gs bs (ps -- sps) sps data))" using assms unfolding compl_struct_def by blast lemma compl_structD4: assumes "compl_struct compl" and "sps ≠ []" and "set sps ⊆ set ps" and "h ∈ set (fst (compl gs bs (ps -- sps) sps data))" and "b ∈ set gs ∪ set bs" and "fst b ≠ 0" shows "¬ lt (fst b) adds⇩t lt (fst h)" using assms unfolding compl_struct_def by blast definition struct_spec :: "('t, 'b::field, 'c, 'd) selT ⇒ ('t, 'b, 'c, 'd) apT ⇒ ('t, 'b, 'c, 'd) abT ⇒ ('t, 'b, 'c, 'd) complT ⇒ bool" where "struct_spec sel ap ab compl ⟷ (sel_spec sel ∧ ap_spec ap ∧ ab_spec ab ∧ compl_struct compl)" lemma struct_specI: assumes "sel_spec sel" and "ap_spec ap" and "ab_spec ab" and "compl_struct compl" shows "struct_spec sel ap ab compl" unfolding struct_spec_def using assms by (intro conjI) lemma struct_specD1: assumes "struct_spec sel ap ab compl" shows "sel_spec sel" using assms unfolding struct_spec_def by (elim conjE) lemma struct_specD2: assumes "struct_spec sel ap ab compl" shows "ap_spec ap" using assms unfolding struct_spec_def by (elim conjE) lemma struct_specD3: assumes "struct_spec sel ap ab compl" shows "ab_spec ab" using assms unfolding struct_spec_def by (elim conjE) lemma struct_specD4: assumes "struct_spec sel ap ab compl" shows "compl_struct compl" using assms unfolding struct_spec_def by (elim conjE) lemmas struct_specD = struct_specD1 struct_specD2 struct_specD3 struct_specD4 definition compl_pmdl :: "('t, 'b::field, 'c, 'd) complT ⇒ bool" where "compl_pmdl compl ⟷ (∀gs bs ps sps data. is_Groebner_basis (fst ` set gs) ⟶ sps ≠ [] ⟶ set sps ⊆ set ps ⟶ unique_idx (gs @ bs) data ⟶ fst ` (set (fst (compl gs bs (ps -- sps) sps data))) ⊆ pmdl (args_to_set (gs, bs, ps)))" lemma compl_pmdlI: assumes "⋀gs bs ps sps data. is_Groebner_basis (fst ` set gs) ⟹ sps ≠ [] ⟹ set sps ⊆ set ps ⟹ unique_idx (gs @ bs) data ⟹ fst ` (set (fst (compl gs bs (ps -- sps) sps data))) ⊆ pmdl (args_to_set (gs, bs, ps))" shows "compl_pmdl compl" unfolding compl_pmdl_def using assms by blast lemma compl_pmdlD: assumes "compl_pmdl compl" and "is_Groebner_basis (fst ` set gs)" and "sps ≠ []" and "set sps ⊆ set ps" and "unique_idx (gs @ bs) data" shows "fst ` (set (fst (compl gs bs (ps -- sps) sps data))) ⊆ pmdl (args_to_set (gs, bs, ps))" using assms unfolding compl_pmdl_def by blast definition compl_conn :: "('t, 'b::field, 'c, 'd) complT ⇒ bool" where "compl_conn compl ⟷ (∀d m gs bs ps sps p q data. dickson_grading d ⟶ fst ` set gs ⊆ dgrad_p_set d m ⟶ is_Groebner_basis (fst ` set gs) ⟶ fst ` set bs ⊆ dgrad_p_set d m ⟶ set ps ⊆ set bs × (set gs ∪ set bs) ⟶ sps ≠ [] ⟶ set sps ⊆ set ps ⟶ unique_idx (gs @ bs) data ⟶ (p, q) ∈ set sps ⟶ fst p ≠ 0 ⟶ fst q ≠ 0 ⟶ crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs) ∪ fst ` set (fst (compl gs bs (ps -- sps) sps data))) (fst p) (fst q))" text ‹Informally, ‹compl_conn compl› means that, for suitable arguments ‹gs›, ‹bs›, ‹ps› and ‹sps›, the value of ‹compl gs bs ps sps› is a list ‹hs› such that the critical pairs of all elements in ‹sps› can be connected modulo ‹set gs ∪ set bs ∪ set hs›.› lemma compl_connI: assumes "⋀d m gs bs ps sps p q data. dickson_grading d ⟹ fst ` set gs ⊆ dgrad_p_set d m ⟹ is_Groebner_basis (fst ` set gs) ⟹ fst ` set bs ⊆ dgrad_p_set d m ⟹ set ps ⊆ set bs × (set gs ∪ set bs) ⟹ sps ≠ [] ⟹ set sps ⊆ set ps ⟹ unique_idx (gs @ bs) data ⟹ (p, q) ∈ set sps ⟹ fst p ≠ 0 ⟹ fst q ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs) ∪ fst ` set (fst (compl gs bs (ps -- sps) sps data))) (fst p) (fst q)" shows "compl_conn compl" unfolding compl_conn_def using assms by presburger lemma compl_connD: assumes "compl_conn compl" and "dickson_grading d" and "fst ` set gs ⊆ dgrad_p_set d m" and "is_Groebner_basis (fst ` set gs)" and "fst ` set bs ⊆ dgrad_p_set d m" and "set ps ⊆ set bs × (set gs ∪ set bs)" and "sps ≠ []" and "set sps ⊆ set ps" and "unique_idx (gs @ bs) data" and "(p, q) ∈ set sps" and "fst p ≠ 0" and "fst q ≠ 0" shows "crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs) ∪ fst ` set (fst (compl gs bs (ps -- sps) sps data))) (fst p) (fst q)" using assms unfolding compl_conn_def Un_assoc by blast subsubsection ‹Function ‹gb_schema_dummy›› definition (in -) add_indices :: "(('a, 'b, 'c) pdata' list × 'd) ⇒ (nat × 'd) ⇒ (('a, 'b, 'c) pdata list × nat × 'd)" where [code del]: "add_indices ns data = (map_idx (λh i. (fst h, i, snd h)) (fst ns) (fst data), fst data + length (fst ns), snd ns)" lemma (in -) add_indices_code [code]: "add_indices (ns, data) (n, data') = (map_idx (λ(h, d) i. (h, i, d)) ns n, n + length ns, data)" by (simp add: add_indices_def case_prod_beta') lemma fst_add_indices: "map fst (fst (add_indices ns data')) = map fst (fst ns)" by (simp add: add_indices_def map_map_idx map_idx_no_idx) corollary fst_set_add_indices: "fst ` set (fst (add_indices ns data')) = fst ` set (fst ns)" using fst_add_indices by (metis set_map) lemma in_set_add_indicesE: assumes "f ∈ set (fst (add_indices aux data))" obtains i where "i < length (fst aux)" and "f = (fst ((fst aux) ! i), fst data + i, snd ((fst aux) ! i))" proof - let ?hs = "fst (add_indices aux data)" from assms obtain i where "i < length ?hs" and "f = ?hs ! i" by (metis in_set_conv_nth) from this(1) have "i < length (fst aux)" by (simp add: add_indices_def) hence "?hs ! i = (fst ((fst aux) ! i), fst data + i, snd ((fst aux) ! i))" unfolding add_indices_def fst_conv by (rule map_idx_nth) hence "f = (fst ((fst aux) ! i), fst data + i, snd ((fst aux) ! i))" by (simp add: ‹f = ?hs ! i›) with ‹i < length (fst aux)› show ?thesis .. qed definition gb_schema_aux_term1 :: "((('t, 'b::field, 'c) pdata list × ('t, 'b, 'c) pdata_pair list) × (('t, 'b, 'c) pdata list × ('t, 'b, 'c) pdata_pair list)) set" where "gb_schema_aux_term1 = {(a, b::('t, 'b, 'c) pdata list). (fst ` set a) ⊐p (fst ` set b)} <*lex*> (measure (card ∘ set))" definition gb_schema_aux_term2 :: "('a ⇒ nat) ⇒ ('t, 'b::field, 'c) pdata list ⇒ ((('t, 'b, 'c) pdata list × ('t, 'b, 'c) pdata_pair list) × (('t, 'b, 'c) pdata list × ('t, 'b, 'c) pdata_pair list)) set" where "gb_schema_aux_term2 d gs = {(a, b). dgrad_p_set_le d (args_to_set (gs, a)) (args_to_set (gs, b)) ∧ component_of_term ` Keys (args_to_set (gs, a)) ⊆ component_of_term ` Keys (args_to_set (gs, b))}" definition gb_schema_aux_term where "gb_schema_aux_term d gs = gb_schema_aux_term1 ∩ gb_schema_aux_term2 d gs" text ‹@{const gb_schema_aux_term} is needed for proving termination of function ‹gb_schema_aux›.› lemma gb_schema_aux_term1_wf_on: assumes "dickson_grading d" and "finite K" shows "wfp_on (λx y. (x, y) ∈ gb_schema_aux_term1) {x::(('t, 'b, 'c) pdata list) × ((('t, 'b::field, 'c) pdata_pair list)). args_to_set (gs, x) ⊆ dgrad_p_set d m ∧ component_of_term ` Keys (args_to_set (gs, x)) ⊆ K}" proof (rule wfp_onI_min) let ?B = "dgrad_p_set d m" let ?A = "{x::(('t, 'b, 'c) pdata list) × ((('t, 'b, 'c) pdata_pair list)). args_to_set (gs, x) ⊆ ?B ∧ component_of_term ` Keys (args_to_set (gs, x)) ⊆ K}" let ?C = "Pow ?B ∩ {F. component_of_term ` Keys F ⊆ K}" have A_sub_Pow: "(image fst) ` set ` fst ` ?A ⊆ ?C" proof fix x assume "x ∈ (image fst) ` set ` fst ` ?A" then obtain x1 where "x1 ∈ set ` fst ` ?A" and x: "x = fst ` x1" by auto from this(1) obtain x2 where "x2 ∈ fst ` ?A" and x1: "x1 = set x2" by auto from this(1) obtain x3 where "x3 ∈ ?A" and x2: "x2 = fst x3" by auto from this(1) have "args_to_set (gs, x3) ⊆ ?B" and "component_of_term ` Keys (args_to_set (gs, x3)) ⊆ K" by simp_all thus "x ∈ ?C" by (simp add: args_to_set_def x x1 x2 image_Un Keys_Un) qed fix x Q assume "x ∈ Q" and "Q ⊆ ?A" have Q_sub_A: "(image fst) ` set ` fst ` Q ⊆ (image fst) ` set ` fst ` ?A" by ((rule image_mono)+, fact) from assms have "wfp_on (⊐p) ?C" by (rule red_supset_wf_on) moreover have "fst ` set (fst x) ∈ (image fst) ` set ` fst ` Q" by (rule, fact refl, rule, fact refl, rule, fact refl, simp add: ‹x ∈ Q›) moreover from Q_sub_A A_sub_Pow have "(image fst) ` set ` fst ` Q ⊆ ?C" by (rule subset_trans) ultimately obtain z1 where "z1 ∈ (image fst) ` set ` fst ` Q" and 2: "⋀y. y ⊐p z1 ⟹ y ∉ (image fst) ` set ` fst ` Q" by (rule wfp_onE_min, auto) from this(1) obtain x1 where "x1 ∈ Q" and z1: "z1 = fst ` set (fst x1)" by auto let ?Q2 = "{q ∈ Q. fst ` set (fst q) = z1}" have "snd x1 ∈ snd ` ?Q2" by (rule, fact refl, simp add: ‹x1 ∈ Q› z1) with wf_measure obtain z2 where "z2 ∈ snd ` ?Q2" and 3: "⋀y. (y, z2) ∈ measure (card ∘ set) ⟹ y ∉ snd ` ?Q2" by (rule wfE_min, blast) from this(1) obtain z where "z ∈ ?Q2" and z2: "z2 = snd z" .. from this(1) have "z ∈ Q" and eq1: "fst ` set (fst z) = z1" by blast+ from this(1) show "∃z∈Q. ∀y∈?A. (y, z) ∈ gb_schema_aux_term1 ⟶ y ∉ Q" proof show "∀y∈?A. (y, z) ∈ gb_schema_aux_term1 ⟶ y ∉ Q" proof (intro ballI impI) fix y assume "y ∈ ?A" assume "(y, z) ∈ gb_schema_aux_term1" hence "(fst ` set (fst y) ⊐p z1 ∨ (fst y = fst z ∧ (snd y, z2) ∈ measure (card ∘ set)))" by (simp add: gb_schema_aux_term1_def eq1[symmetric] z2 in_lex_prod_alt) thus "y ∉ Q" proof (elim disjE conjE) assume "fst ` set (fst y) ⊐p z1" hence "fst ` set (fst y) ∉ (image fst) ` set ` fst ` Q" by (rule 2) thus ?thesis by auto next assume "(snd y, z2) ∈ measure (card ∘ set)" hence "snd y ∉ snd ` ?Q2" by (rule 3) hence "y ∉ ?Q2" by blast moreover assume "fst y = fst z" ultimately show ?thesis by (simp add: eq1) qed qed qed qed lemma gb_schema_aux_term_wf: assumes "dickson_grading d" shows "wf (gb_schema_aux_term d gs)" proof (rule wfI_min) fix x::"(('t, 'b, 'c) pdata list) × (('t, 'b, 'c) pdata_pair list)" and Q assume "x ∈ Q" let ?A = "args_to_set (gs, x)" have "finite ?A" by (simp add: args_to_set_def) then obtain m where A: "?A ⊆ dgrad_p_set d m" by (rule dgrad_p_set_exhaust) define K where "K = component_of_term ` Keys ?A" from ‹finite ?A› have "finite K" unfolding K_def by (rule finite_imp_finite_component_Keys) let ?B = "dgrad_p_set d m" let ?Q = "{q ∈ Q. args_to_set (gs, q) ⊆ ?B ∧ component_of_term ` Keys (args_to_set (gs, q)) ⊆ K}" from assms ‹finite K› have "wfp_on (λx y. (x, y) ∈ gb_schema_aux_term1) {x. args_to_set (gs, x) ⊆ ?B ∧ component_of_term ` Keys (args_to_set (gs, x)) ⊆ K}" by (rule gb_schema_aux_term1_wf_on) moreover from ‹x ∈ Q› A have "x ∈ ?Q" by (simp add: K_def) moreover have "?Q ⊆ {x. args_to_set (gs, x) ⊆ ?B ∧ component_of_term ` Keys (args_to_set (gs, x)) ⊆ K}" by auto ultimately obtain z where "z ∈ ?Q" and *: "⋀y. (y, z) ∈ gb_schema_aux_term1 ⟹ y ∉ ?Q" by (rule wfp_onE_min, blast) from this(1) have "z ∈ Q" and a: "args_to_set (gs, z) ⊆ ?B" and b: "component_of_term ` Keys (args_to_set (gs, z)) ⊆ K" by simp_all from this(1) show "∃z∈Q. ∀y. (y, z) ∈ gb_schema_aux_term d gs ⟶ y ∉ Q" proof show "∀y. (y, z) ∈ gb_schema_aux_term d gs ⟶ y ∉ Q" proof (intro allI impI) fix y assume "(y, z) ∈ gb_schema_aux_term d gs" hence "(y, z) ∈ gb_schema_aux_term1" and "(y, z) ∈ gb_schema_aux_term2 d gs" by (simp_all add: gb_schema_aux_term_def) from this(2) have "dgrad_p_set_le d (args_to_set (gs, y)) (args_to_set (gs, z))" and comp_sub: "component_of_term ` Keys (args_to_set (gs, y)) ⊆ component_of_term ` Keys (args_to_set (gs, z))" by (simp_all add: gb_schema_aux_term2_def) from this(1) ‹args_to_set (gs, z) ⊆ ?B› have "args_to_set (gs, y) ⊆ ?B" by (rule dgrad_p_set_le_dgrad_p_set) moreover from comp_sub b have "component_of_term ` Keys (args_to_set (gs, y)) ⊆ K" by (rule subset_trans) moreover from ‹(y, z) ∈ gb_schema_aux_term1› have "y ∉ ?Q" by (rule *) ultimately show "y ∉ Q" by simp qed qed qed lemma dgrad_p_set_le_args_to_set_ab: assumes "dickson_grading d" and "ap_spec ap" and "ab_spec ab" and "compl_struct compl" assumes "sps ≠ []" and "set sps ⊆ set ps" and "hs = fst (add_indices (compl gs bs (ps -- sps) sps data) data)" shows "dgrad_p_set_le d (args_to_set (gs, ab gs bs hs data', ap gs bs (ps -- sps) hs data')) (args_to_set (gs, bs, ps))" (is "dgrad_p_set_le _ ?l ?r") proof - have "dgrad_p_set_le d ?l (fst ` (set gs ∪ set bs ∪ fst ` set (ps -- sps) ∪ snd ` set (ps -- sps) ∪ set hs))" by (rule dgrad_p_set_le_subset, rule args_to_set_subset[OF assms(2, 3)]) also have "dgrad_p_set_le d ... ?r" unfolding image_Un proof (intro dgrad_p_set_leI_Un) show "dgrad_p_set_le d (fst ` set gs) (args_to_set (gs, bs, ps))" by (rule dgrad_p_set_le_subset, auto simp add: args_to_set_def) next show "dgrad_p_set_le d (fst ` set bs) (args_to_set (gs, bs, ps))" by (rule dgrad_p_set_le_subset, auto simp add: args_to_set_def) next show "dgrad_p_set_le d (fst ` fst ` set (ps -- sps)) (args_to_set (gs, bs, ps))" by (rule dgrad_p_set_le_subset, auto simp add: args_to_set_def set_diff_list) next show "dgrad_p_set_le d (fst ` snd ` set (ps -- sps)) (args_to_set (gs, bs, ps))" by (rule dgrad_p_set_le_subset, auto simp add: args_to_set_def set_diff_list) next from assms(4, 1, 5, 6) show "dgrad_p_set_le d (fst ` set hs) (args_to_set (gs, bs, ps))" unfolding assms(7) fst_set_add_indices by (rule compl_structD1) qed finally show ?thesis . qed corollary dgrad_p_set_le_args_to_set_struct: assumes "dickson_grading d" and "struct_spec sel ap ab compl" and "ps ≠ []" assumes "sps = sel gs bs ps data" and "hs = fst (add_indices (compl gs bs (ps -- sps) sps data) data)" shows "dgrad_p_set_le d (args_to_set (gs, ab gs bs hs data', ap gs bs (ps -- sps) hs data')) (args_to_set (gs, bs, ps))" proof - from assms(2) have sel: "sel_spec sel" and ap: "ap_spec ap" and ab: "ab_spec ab" and compl: "compl_struct compl" by (rule struct_specD)+ from sel assms(3) have "sps ≠ []" and "set sps ⊆ set ps" unfolding assms(4) by (rule sel_specD1, rule sel_specD2) from assms(1) ap ab compl this assms(5) show ?thesis by (rule dgrad_p_set_le_args_to_set_ab) qed lemma components_subset_ab: assumes "ap_spec ap" and "ab_spec ab" and "compl_struct compl" assumes "sps ≠ []" and "set sps ⊆ set ps" and "hs = fst (add_indices (compl gs bs (ps -- sps) sps data) data)" shows "component_of_term ` Keys (args_to_set (gs, ab gs bs hs data', ap gs bs (ps -- sps) hs data')) ⊆ component_of_term ` Keys (args_to_set (gs, bs, ps))" (is "?l ⊆ ?r") proof - have "?l ⊆ component_of_term ` Keys (fst ` (set gs ∪ set bs ∪ fst ` set (ps -- sps) ∪ snd ` set (ps -- sps) ∪ set hs))" by (rule image_mono, rule Keys_mono, rule args_to_set_subset[OF assms(1, 2)]) also have "... ⊆ ?r" unfolding image_Un Keys_Un Un_subset_iff proof (intro conjI) show "component_of_term ` Keys (fst ` set gs) ⊆ component_of_term ` Keys (args_to_set (gs, bs, ps))" by (rule image_mono, rule Keys_mono, auto simp add: args_to_set_def) next show "component_of_term ` Keys (fst ` set bs) ⊆ component_of_term ` Keys (args_to_set (gs, bs, ps))" by (rule image_mono, rule Keys_mono, auto simp add: args_to_set_def) next show "component_of_term ` Keys (fst ` fst ` set (ps -- sps)) ⊆ component_of_term ` Keys (args_to_set (gs, bs, ps))" by (rule image_mono, rule Keys_mono, auto simp add: set_diff_list args_to_set_def) next show "component_of_term ` Keys (fst ` snd ` set (ps -- sps)) ⊆ component_of_term ` Keys (args_to_set (gs, bs, ps))" by (rule image_mono, rule Keys_mono, auto simp add: args_to_set_def set_diff_list) next from assms(3, 4, 5) show "component_of_term ` Keys (fst ` set hs) ⊆ component_of_term ` Keys (args_to_set (gs, bs, ps))" unfolding assms(6) fst_set_add_indices by (rule compl_structD2) qed finally show ?thesis . qed corollary components_subset_struct: assumes "struct_spec sel ap ab compl" and "ps ≠ []" assumes "sps = sel gs bs ps data" and "hs = fst (add_indices (compl gs bs (ps -- sps) sps data) data)" shows "component_of_term ` Keys (args_to_set (gs, ab gs bs hs data', ap gs bs (ps -- sps) hs data')) ⊆ component_of_term ` Keys (args_to_set (gs, bs, ps))" proof - from assms(1) have sel: "sel_spec sel" and ap: "ap_spec ap" and ab: "ab_spec ab" and compl: "compl_struct compl" by (rule struct_specD)+ from sel assms(2) have "sps ≠ []" and "set sps ⊆ set ps" unfolding assms(3) by (rule sel_specD1, rule sel_specD2) from ap ab compl this assms(4) show ?thesis by (rule components_subset_ab) qed corollary components_struct: assumes "struct_spec sel ap ab compl" and "ps ≠ []" and "set ps ⊆ set bs × (set gs ∪ set bs)" assumes "sps = sel gs bs ps data" and "hs = fst (add_indices (compl gs bs (ps -- sps) sps data) data)" shows "component_of_term ` Keys (args_to_set (gs, ab gs bs hs data', ap gs bs (ps -- sps) hs data')) = component_of_term ` Keys (args_to_set (gs, bs, ps))" (is "?l = ?r") proof from assms(1, 2, 4, 5) show "?l ⊆ ?r" by (rule components_subset_struct) next from assms(1) have ap: "ap_spec ap" and ab: "ab_spec ab" and compl: "compl_struct compl" by (rule struct_specD)+ from ap ab assms(3) have sub: "set (ap gs bs (ps -- sps) hs data') ⊆ set (ab gs bs hs data') × (set gs ∪ set (ab gs bs hs data'))" by (rule subset_Times_ap) show "?r ⊆ ?l" by (simp add: args_to_set_subset_Times[OF sub] args_to_set_subset_Times[OF assms(3)] ab_specD1[OF ab], rule image_mono, rule Keys_mono, blast) qed lemma struct_spec_red_supset: assumes "struct_spec sel ap ab compl" and "ps ≠ []" and "sps = sel gs bs ps data" and "hs = fst (add_indices (compl gs bs (ps -- sps) sps data) data)" and "hs ≠ []" shows "(fst ` set (ab gs bs hs data')) ⊐p (fst ` set bs)" proof - from assms(5) have "set hs ≠ {}" by simp then obtain h' where "h' ∈ set hs" by fastforce let ?h = "fst h'" let ?m = "monomial (lc ?h) (lt ?h)" from ‹h' ∈ set hs› have h_in: "?h ∈ fst ` set hs" by simp hence "?h ∈ fst ` set (fst (compl gs bs (ps -- sps) sps data))" by (simp only: assms(4) fst_set_add_indices) then obtain h'' where h''_in: "h'' ∈ set (fst (compl gs bs (ps -- sps) sps data))" and "?h = fst h''" .. from assms(1) have sel: "sel_spec sel" and ap: "ap_spec ap" and ab: "ab_spec ab" and compl: "compl_struct compl" by (rule struct_specD)+ from sel assms(2) have "sps ≠ []" and "set sps ⊆ set ps" unfolding assms(3) by (rule sel_specD1, rule sel_specD2) from h_in compl_structD3[OF compl this] have "?h ≠ 0" unfolding assms(4) fst_set_add_indices by metis show ?thesis proof (simp add: ab_specD1[OF ab] image_Un, rule) fix q assume "is_red (fst ` set bs) q" moreover have "fst ` set bs ⊆ fst ` set bs ∪ fst ` set hs" by simp ultimately show "is_red (fst ` set bs ∪ fst ` set hs) q" by (rule is_red_subset) next from ‹?h ≠ 0› have "lc ?h ≠ 0" by (rule lc_not_0) moreover have "?h ∈ {?h}" .. ultimately have "is_red {?h} ?m" using ‹?h ≠ 0› adds_term_refl by (rule is_red_monomialI) moreover have "{?h} ⊆ fst ` set bs ∪ fst ` set hs" using h_in by simp ultimately show "is_red (fst ` set bs ∪ fst ` set hs) ?m" by (rule is_red_subset) next show "¬ is_red (fst ` set bs) ?m" proof assume "is_red (fst ` set bs) ?m" then obtain b' where "b' ∈ fst ` set bs" and "b' ≠ 0" and "lt b' adds⇩t lt ?h" by (rule is_red_monomialE) from this(1) obtain b where "b ∈ set bs" and b': "b' = fst b" .. from this(1) have "b ∈ set gs ∪ set bs" by simp from ‹b' ≠ 0› have "fst b ≠ 0" by (simp add: b') with compl ‹sps ≠ []› ‹set sps ⊆ set ps› h''_in ‹b ∈ set gs ∪ set bs› have "¬ lt (fst b) adds⇩t lt ?h" unfolding ‹?h = fst h''› by (rule compl_structD4) from this ‹lt b' adds⇩t lt ?h› show False by (simp add: b') qed qed qed lemma unique_idx_append: assumes "unique_idx gs data" and "(hs, data') = add_indices aux data" shows "unique_idx (gs @ hs) data'" proof - from assms(2) have hs: "hs = fst (add_indices aux data)" and data': "data' = snd (add_indices aux data)" by (metis fst_conv, metis snd_conv) have len: "length hs = length (fst aux)" by (simp add: hs add_indices_def) have eq: "fst data' = fst data + length hs" by (simp add: data' add_indices_def hs) show ?thesis proof (rule unique_idxI) fix f g assume "f ∈ set (gs @ hs)" and "g ∈ set (gs @ hs)" hence d1: "f ∈ set gs ∪ set hs" and d2: "g ∈ set gs ∪ set hs" by simp_all assume id_eq: "fst (snd f) = fst (snd g)" from d1 show "f = g" proof assume "f ∈ set gs" from d2 show ?thesis proof assume "g ∈ set gs" from assms(1) ‹f ∈ set gs› this id_eq show ?thesis by (rule unique_idxD1) next assume "g ∈ set hs" then obtain j where "g = (fst (fst aux ! j), fst data + j, snd (fst aux ! j))" unfolding hs by (rule in_set_add_indicesE) hence "fst (snd g) = fst data + j" by simp moreover from assms(1) ‹f ∈ set gs› have "fst (snd f) < fst data" by (rule unique_idxD2) ultimately show ?thesis by (simp add: id_eq) qed next assume "f ∈ set hs" then obtain i where f: "f = (fst (fst aux ! i), fst data + i, snd (fst aux ! i))" unfolding hs by (rule in_set_add_indicesE) hence *: "fst (snd f) = fst data + i" by simp from d2 show ?thesis proof assume "g ∈ set gs" with assms(1) have "fst (snd g) < fst data" by (rule unique_idxD2) with * show ?thesis by (simp add: id_eq) next assume "g ∈ set hs" then obtain j where g: "g = (fst (fst aux ! j), fst data + j, snd (fst aux ! j))" unfolding hs by (rule in_set_add_indicesE) hence "fst (snd g) = fst data + j" by simp with * have "i = j" by (simp add: id_eq) thus ?thesis by (simp add: f g) qed qed next fix f assume "f ∈ set (gs @ hs)" hence "f ∈ set gs ∪ set hs" by simp thus "fst (snd f) < fst data'" proof assume "f ∈ set gs" with assms(1) have "fst (snd f) < fst data" by (rule unique_idxD2) also have "... ≤ fst data'" by (simp add: eq) finally show ?thesis . next assume "f ∈ set hs" then obtain i where "i < length (fst aux)" and "f = (fst (fst aux ! i), fst data + i, snd (fst aux ! i))" unfolding hs by (rule in_set_add_indicesE) from this(2) have "fst (snd f) = fst data + i" by simp also from ‹i < length (fst aux)› have "... < fst data + length (fst aux)" by simp finally show ?thesis by (simp only: eq len) qed qed qed corollary unique_idx_ab: assumes "ab_spec ab" and "unique_idx (gs @ bs) data" and "(hs, data') = add_indices aux data" shows "unique_idx (gs @ ab gs bs hs data') data'" proof - from assms(2, 3) have "unique_idx ((gs @ bs) @ hs) data'" by (rule unique_idx_append) thus ?thesis by (simp add: unique_idx_def ab_specD1[OF assms(1)]) qed lemma rem_comps_spec_struct: assumes "struct_spec sel ap ab compl" and "rem_comps_spec (gs @ bs) data" and "ps ≠ []" and "set ps ⊆ (set bs) × (set gs ∪ set bs)" and "sps = sel gs bs ps (snd data)" and "aux = compl gs bs (ps -- sps) sps (snd data)" and "(hs, data') = add_indices aux (snd data)" shows "rem_comps_spec (gs @ ab gs bs hs data') (fst data - count_const_lt_components (fst aux), data')" proof - from assms(1) have sel: "sel_spec sel" and ap: "ap_spec ap" and ab: "ab_spec ab" and compl: "compl_struct compl" by (rule struct_specD)+ from ap ab assms(4) have sub: "set (ap gs bs (ps -- sps) hs data') ⊆ set (ab gs bs hs data') × (set gs ∪ set (ab gs bs hs data'))" by (rule subset_Times_ap) have hs: "hs = fst (add_indices aux (snd data))" by (simp add: assms(7)[symmetric]) from sel assms(3) have "sps ≠ []" and "set sps ⊆ set ps" unfolding assms(5) by (rule sel_specD1, rule sel_specD2) have eq0: "fst ` set (fst aux) - {0} = fst ` set (fst aux)" by (rule Diff_triv, simp add: Int_insert_right assms(6), rule compl_structD3, fact+) have "component_of_term ` Keys (fst ` set (gs @ ab gs bs hs data')) = component_of_term ` Keys (args_to_set (gs, ab gs bs hs data', ap gs bs (ps -- sps) hs data'))" by (simp add: args_to_set_subset_Times[OF sub] image_Un) also from assms(1, 3, 4, 5) hs have "... = component_of_term ` Keys (args_to_set (gs, bs, ps))" unfolding assms(6) by (rule components_struct) also have "... = component_of_term ` Keys (fst ` set (gs @ bs))" by (simp add: args_to_set_subset_Times[OF assms(4)] image_Un) finally have eq: "component_of_term ` Keys (fst ` set (gs @ ab gs bs hs data')) = component_of_term ` Keys (fst ` set (gs @ bs))" . from assms(2) have eq2: "card (component_of_term ` Keys (fst ` set (gs @ bs))) = fst data + card (const_lt_component ` (fst ` set (gs @ bs) - {0}) - {None})" (is "?a = _ + ?b") by (simp only: rem_comps_spec_def) have eq3: "card (const_lt_component ` (fst ` set (gs @ ab gs bs hs data') - {0}) - {None}) = ?b + count_const_lt_components (fst aux)" (is "?c = _") proof (simp add: ab_specD1[OF ab] image_Un Un_assoc[symmetric] Un_Diff count_const_lt_components_alt hs fst_set_add_indices eq0, rule card_Un_disjoint) show "finite (const_lt_component ` (fst ` set gs - {0}) - {None} ∪ (const_lt_component ` (fst ` set bs - {0}) - {None}))" by (intro finite_UnI finite_Diff finite_imageI finite_set) next show "finite (const_lt_component ` fst ` set (fst aux) - {None})" by (rule finite_Diff, intro finite_imageI, fact finite_set) next have "(const_lt_component ` (fst ` (set gs ∪ set bs) - {0}) - {None}) ∩ (const_lt_component ` fst ` set (fst aux) - {None}) = (const_lt_component ` (fst ` (set gs ∪ set bs) - {0}) ∩ const_lt_component ` fst ` set (fst aux)) - {None}" by blast also have "... = {}" proof (simp, rule, simp, elim conjE) fix k assume "k ∈ const_lt_component ` (fst ` (set gs ∪ set bs) - {0})" then obtain b where "b ∈ set gs ∪ set bs" and "fst b ≠ 0" and k1: "k = const_lt_component (fst b)" by blast assume "k ∈ const_lt_component ` fst ` set (fst aux)" then obtain h where "h ∈ set (fst aux)" and k2: "k = const_lt_component (fst h)" by blast show "k = None" proof (rule ccontr, simp, elim exE) fix k' assume "k = Some k'" hence "lp (fst b) = 0" and "component_of_term (lt (fst b)) = k'" unfolding k1 by (rule const_lt_component_SomeD1, rule const_lt_component_SomeD2) moreover from ‹k = Some k'› have "lp (fst h) = 0" and "component_of_term (lt (fst h)) = k'" unfolding k2 by (rule const_lt_component_SomeD1, rule const_lt_component_SomeD2) ultimately have "lt (fst b) adds⇩t lt (fst h)" by (simp add: adds_term_def) moreover from compl ‹sps ≠ []› ‹set sps ⊆ set ps› ‹h ∈ set (fst aux)› ‹b ∈ set gs ∪ set bs› ‹fst b ≠ 0› have "¬ lt (fst b) adds⇩t lt (fst h)" unfolding assms(6) by (rule compl_structD4) ultimately show False by simp qed qed finally show "(const_lt_component ` (fst ` set gs - {0}) - {None} ∪ (const_lt_component ` (fst ` set bs - {0}) - {None})) ∩ (const_lt_component ` fst ` set (fst aux) - {None}) = {}" by (simp only: Un_Diff image_Un) qed have "?c ≤ ?a" unfolding eq[symmetric] by (rule card_const_lt_component_le, rule finite_imageI, fact finite_set) hence le: "count_const_lt_components (fst aux) ≤ fst data" by (simp only: eq2 eq3) show ?thesis by (simp only: rem_comps_spec_def eq eq2 eq3, simp add: le) qed lemma pmdl_struct: assumes "struct_spec sel ap ab compl" and "compl_pmdl compl" and "is_Groebner_basis (fst ` set gs)" and "ps ≠ []" and "set ps ⊆ (set bs) × (set gs ∪ set bs)" and "unique_idx (gs @ bs) (snd data)" and "sps = sel gs bs ps (snd data)" and "aux = compl gs bs (ps -- sps) sps (snd data)" and "(hs, data') = add_indices aux (snd data)" shows "pmdl (fst ` set (gs @ ab gs bs hs data')) = pmdl (fst ` set (gs @ bs))" proof - have hs: "hs = fst (add_indices aux (snd data))" by (simp add: assms(9)[symmetric]) from assms(1) have sel: "sel_spec sel" and ab: "ab_spec ab" by (rule struct_specD)+ have eq: "fst ` (set gs ∪ set (ab gs bs hs data')) = fst ` (set gs ∪ set bs) ∪ fst ` set hs" by (auto simp add: ab_specD1[OF ab]) show ?thesis proof (simp add: eq, rule) show "pmdl (fst ` (set gs ∪ set bs) ∪ fst ` set hs) ⊆ pmdl (fst ` (set gs ∪ set bs))" proof (rule pmdl.span_subset_spanI, simp only: Un_subset_iff, rule) show "fst ` (set gs ∪ set bs) ⊆ pmdl (fst ` (set gs ∪ set bs))" by (fact pmdl.span_superset) next from sel assms(4) have "sps ≠ []" and "set sps ⊆ set ps" unfolding assms(7) by (rule sel_specD1, rule sel_specD2) with assms(2, 3) have "fst ` set hs ⊆ pmdl (args_to_set (gs, bs, ps))" unfolding hs assms(8) fst_set_add_indices using assms(6) by (rule compl_pmdlD) thus "fst ` set hs ⊆ pmdl (fst ` (set gs ∪ set bs))" by (simp only: args_to_set_subset_Times[OF assms(5)] image_Un) qed next show "pmdl (fst ` (set gs ∪ set bs)) ⊆ pmdl (fst ` (set gs ∪ set bs) ∪ fst ` set hs)" by (rule pmdl.span_mono, blast) qed qed lemma discarded_subset: assumes "ab_spec ab" and "D' = D ∪ (set hs × (set gs ∪ set bs ∪ set hs) ∪ set (ps -- sps) -⇩p set (ap gs bs (ps -- sps) hs data'))" and "set ps ⊆ set bs × (set gs ∪ set bs)" and "D ⊆ (set gs ∪ set bs) × (set gs ∪ set bs)" shows "D' ⊆ (set gs ∪ set (ab gs bs hs data')) × (set gs ∪ set (ab gs bs hs data'))" proof - from assms(1) have eq: "set (ab gs bs hs data') = set bs ∪ set hs" by (rule ab_specD1) from assms(4) have "D ⊆ (set gs ∪ (set bs ∪ set hs)) × (set gs ∪ (set bs ∪ set hs))" by fastforce moreover have "set hs × (set gs ∪ set bs ∪ set hs) ∪ set (ps -- sps) -⇩p set (ap gs bs (ps -- sps) hs data') ⊆ (set gs ∪ (set bs ∪ set hs)) × (set gs ∪ (set bs ∪ set hs))" (is "?l ⊆ ?r") proof (rule subset_trans) show "?l ⊆ set hs × (set gs ∪ set bs ∪ set hs) ∪ set (ps -- sps)" by (simp add: minus_pairs_def) next have "set hs × (set gs ∪ set bs ∪ set hs) ⊆ ?r" by fastforce moreover have "set (ps -- sps) ⊆ ?r" proof (rule subset_trans) show "set (ps -- sps) ⊆ set ps" by (auto simp: set_diff_list) next from assms(3) show "set ps ⊆ ?r" by fastforce qed ultimately show "set hs × (set gs ∪ set bs ∪ set hs) ∪ set (ps -- sps) ⊆ ?r" by (rule Un_least) qed ultimately show ?thesis unfolding eq assms(2) by (rule Un_least) qed lemma compl_struct_disjoint: assumes "compl_struct compl" and "sps ≠ []" and "set sps ⊆ set ps" shows "fst ` set (fst (compl gs bs (ps -- sps) sps data)) ∩ fst ` (set gs ∪ set bs) = {}" proof (rule, rule) fix x assume "x ∈ fst ` set (fst (compl gs bs (ps -- sps) sps data)) ∩ fst ` (set gs ∪ set bs)" hence x_in: "x ∈ fst ` set (fst (compl gs bs (ps -- sps) sps data))" and "x ∈ fst ` (set gs ∪ set bs)" by simp_all from x_in obtain h where h_in: "h ∈ set (fst (compl gs bs (ps -- sps) sps data))" and x1: "x = fst h" .. from compl_structD3[OF assms, of gs bs data] x_in have "x ≠ 0" by auto from ‹x ∈ fst ` (set gs ∪ set bs)› obtain b where b_in: "b ∈ set gs ∪ set bs" and x2: "x = fst b" .. from ‹x ≠ 0› have "fst b ≠ 0" by (simp add: x2) with assms h_in b_in have "¬ lt (fst b) adds⇩t lt (fst h)" by (rule compl_structD4) hence "¬ lt x adds⇩t lt x" by (simp add: x1[symmetric] x2) from this adds_term_refl show "x ∈ {}" .. qed simp context fixes sel::"('t, 'b::field, 'c::default, 'd) selT" and ap::"('t, 'b, 'c, 'd) apT" and ab::"('t, 'b, 'c, 'd) abT" and compl::"('t, 'b, 'c, 'd) complT" and gs::"('t, 'b, 'c) pdata list" begin function (domintros) gb_schema_dummy :: "nat × nat × 'd ⇒ ('t, 'b, 'c) pdata_pair set ⇒ ('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata_pair list ⇒ (('t, 'b, 'c) pdata list × ('t, 'b, 'c) pdata_pair set)" where "gb_schema_dummy data D bs ps = (if ps = [] then (gs @ bs, D) else (let sps = sel gs bs ps (snd data); ps0 = ps -- sps; aux = compl gs bs ps0 sps (snd data); remcomps = fst (data) - count_const_lt_components (fst aux) in (if remcomps = 0 then (full_gb (gs @ bs), D) else let (hs, data') = add_indices aux (snd data) in gb_schema_dummy (remcomps, data') (D ∪ ((set hs × (set gs ∪ set bs ∪ set hs) ∪ set (ps -- sps)) -⇩p set (ap gs bs ps0 hs data'))) (ab gs bs hs data') (ap gs bs ps0 hs data') ) ) )" by pat_completeness auto lemma gb_schema_dummy_domI1: "gb_schema_dummy_dom (data, D, bs, [])" by (rule gb_schema_dummy.domintros, simp) lemma gb_schema_dummy_domI2: assumes "struct_spec sel ap ab compl" shows "gb_schema_dummy_dom (data, D, args)" proof - from assms have sel: "sel_spec sel" and ap: "ap_spec ap" and ab: "ab_spec ab" by (rule struct_specD)+ from ex_dgrad obtain d::"'a ⇒ nat" where dg: "dickson_grading d" .. let ?R = "(gb_schema_aux_term d gs)" from dg have "wf ?R" by (rule gb_schema_aux_term_wf) thus ?thesis proof (induct args arbitrary: data D rule: wf_induct_rule) fix x data D assume IH: "⋀y data' D'. (y, x) ∈ ?R ⟹ gb_schema_dummy_dom (data', D', y)" obtain bs ps where x: "x = (bs, ps)" by (meson case_prodE case_prodI2) show "gb_schema_dummy_dom (data, D, x)" unfolding x proof (rule gb_schema_dummy.domintros) fix rc0 n0 data0 hs n1 data1 assume "ps ≠ []" and hs_data': "(hs, n1, data1) = add_indices (compl gs bs (ps -- sel gs bs ps (n0, data0)) (sel gs bs ps (n0, data0)) (n0, data0)) (n0, data0)" and data: "data = (rc0, n0, data0)" define sps where "sps = sel gs bs ps (n0, data0)" define data' where "data' = (n1, data1)" define D' where "D' = D ∪ (set hs × (set gs ∪ set bs ∪ set hs) ∪ set (ps -- sps) -⇩p set (ap gs bs (ps -- sps) hs data'))" define rc where "rc = rc0 - count_const_lt_components (fst (compl gs bs (ps -- sel gs bs ps (n0, data0)) (sel gs bs ps (n0, data0)) (n0, data0)))" from hs_data' have hs: "hs = fst (add_indices (compl gs bs (ps -- sps) sps (snd data)) (snd data))" unfolding sps_def data snd_conv by (metis fstI) show "gb_schema_dummy_dom ((rc, data'), D', ab gs bs hs data', ap gs bs (ps -- sps) hs data')" proof (rule IH, simp add: x gb_schema_aux_term_def gb_schema_aux_term1_def gb_schema_aux_term2_def, intro conjI) show "fst ` set (ab gs bs hs data') ⊐p fst ` set bs ∨ ab gs bs hs data' = bs ∧ card (set (ap gs bs (ps -- sps) hs data')) < card (set ps)" proof (cases "hs = []") case True have "ab gs bs hs data' = bs ∧ card (set (ap gs bs (ps -- sps) hs data')) < card (set ps)" proof (simp only: True, rule) from ab show "ab gs bs [] data' = bs" by (rule ab_specD2) next from sel ‹ps ≠ []› have "sps ≠ []" and "set sps ⊆ set ps" unfolding sps_def by (rule sel_specD1, rule sel_specD2) moreover from sel_specD1[OF sel ‹ps ≠ []›] have "set sps ≠ {}" by (simp add: sps_def) ultimately have "set ps ∩ set sps ≠ {}" by (simp add: inf.absorb_iff2) hence "set (ps -- sps) ⊂ set ps" unfolding set_diff_list by fastforce hence "card (set (ps -- sps)) < card (set ps)" by (simp add: psubset_card_mono) moreover have "card (set (ap gs bs (ps -- sps) [] data')) ≤ card (set (ps -- sps))" by (rule card_mono, fact finite_set, rule ap_spec_Nil_subset, fact ap) ultimately show "card (set (ap gs bs (ps -- sps) [] data')) < card (set ps)" by simp qed thus ?thesis .. next case False with assms ‹ps ≠ []› sps_def hs have "fst ` set (ab gs bs hs data') ⊐p fst ` set bs" unfolding data snd_conv by (rule struct_spec_red_supset) thus ?thesis .. qed next from dg assms ‹ps ≠ []› sps_def hs show "dgrad_p_set_le d (args_to_set (gs, ab gs bs hs data', ap gs bs (ps -- sps) hs data')) (args_to_set (gs, bs, ps))" unfolding data snd_conv by (rule dgrad_p_set_le_args_to_set_struct) next from assms ‹ps ≠ []› sps_def hs show "component_of_term ` Keys (args_to_set (gs, ab gs bs hs data', ap gs bs (ps -- sps) hs data')) ⊆ component_of_term ` Keys (args_to_set (gs, bs, ps))" unfolding data snd_conv by (rule components_subset_struct) qed qed qed qed lemmas gb_schema_dummy_simp = gb_schema_dummy.psimps[OF gb_schema_dummy_domI2] lemma gb_schema_dummy_Nil [simp]: "gb_schema_dummy data D bs [] = (gs @ bs, D)" by (simp add: gb_schema_dummy.psimps[OF gb_schema_dummy_domI1]) lemma gb_schema_dummy_not_Nil: assumes "struct_spec sel ap ab compl" and "ps ≠ []" shows "gb_schema_dummy data D bs ps = (let sps = sel gs bs ps (snd data); ps0 = ps -- sps; aux = compl gs bs ps0 sps (snd data); remcomps = fst (data) - count_const_lt_components (fst aux) in (if remcomps = 0 then (full_gb (gs @ bs), D) else let (hs, data') = add_indices aux (snd data) in gb_schema_dummy (remcomps, data') (D ∪ ((set hs × (set gs ∪ set bs ∪ set hs) ∪ set (ps -- sps)) -⇩p set (ap gs bs ps0 hs data'))) (ab gs bs hs data') (ap gs bs ps0 hs data') ) )" by (simp add: gb_schema_dummy_simp[OF assms(1)] assms(2)) lemma gb_schema_dummy_induct [consumes 1, case_names base rec1 rec2]: assumes "struct_spec sel ap ab compl" assumes base: "⋀bs data D. P data D bs [] (gs @ bs, D)" and rec1: "⋀bs ps sps data D. ps ≠ [] ⟹ sps = sel gs bs ps (snd data) ⟹ fst (data) ≤ count_const_lt_components (fst (compl gs bs (ps -- sps) sps (snd data))) ⟹ P data D bs ps (full_gb (gs @ bs), D)" and rec2: "⋀bs ps sps aux hs rc data data' D D'. ps ≠ [] ⟹ sps = sel gs bs ps (snd data) ⟹ aux = compl gs bs (ps -- sps) sps (snd data) ⟹ (hs, data') = add_indices aux (snd data) ⟹ rc = fst data - count_const_lt_components (fst aux) ⟹ 0 < rc ⟹ D' = (D ∪ ((set hs × (set gs ∪ set bs ∪ set hs) ∪ set (ps -- sps)) -⇩p set (ap gs bs (ps -- sps) hs data'))) ⟹ P (rc, data') D' (ab gs bs hs data') (ap gs bs (ps -- sps) hs data') (gb_schema_dummy (rc, data') D' (ab gs bs hs data') (ap gs bs (ps -- sps) hs data')) ⟹ P data D bs ps (gb_schema_dummy (rc, data') D' (ab gs bs hs data') (ap gs bs (ps -- sps) hs data'))" shows "P data D bs ps (gb_schema_dummy data D bs ps)" proof - from assms(1) have "gb_schema_dummy_dom (data, D, bs, ps)" by (rule gb_schema_dummy_domI2) thus ?thesis proof (induct data D bs ps rule: gb_schema_dummy.pinduct) case (1 data D bs ps) show ?case proof (cases "ps = []") case True show ?thesis by (simp add: True, rule base) next case False show ?thesis proof (simp only: gb_schema_dummy_not_Nil[OF assms(1) False] Let_def split: if_split, intro conjI impI) define sps where "sps = sel gs bs ps (snd data)" assume "fst data - count_const_lt_components (fst (compl gs bs (ps -- sps) sps (snd data))) = 0" hence "fst data ≤ count_const_lt_components (fst (compl gs bs (ps -- sps) sps (snd data)))" by simp with False sps_def show "P data D bs ps (full_gb (gs @ bs), D)" by (rule rec1) next define sps where "sps = sel gs bs ps (snd data)" define aux where "aux = compl gs bs (ps -- sps) sps (snd data)" define hs where "hs = fst (add_indices aux (snd data))" define data' where "data' = snd (add_indices aux (snd data))" define rc where "rc = fst data - count_const_lt_components (fst aux)" define D' where "D' = (D ∪ ((set hs × (set gs ∪ set bs ∪ set hs) ∪ set (ps -- sps)) -⇩p set (ap gs bs (ps -- sps) hs data')))" have eq: "add_indices aux (snd data) = (hs, data')" by (simp add: hs_def data'_def) assume "rc ≠ 0" hence "0 < rc" by simp show "P data D bs ps (case add_indices aux (snd data) of (hs, data') ⇒ gb_schema_dummy (rc, data') (D ∪ (set hs × (set gs ∪ set bs ∪ set hs) ∪ set (ps -- sps) -⇩p set (ap gs bs (ps -- sps) hs data'))) (ab gs bs hs data') (ap gs bs (ps -- sps) hs data'))" unfolding eq prod.case D'_def[symmetric] using False sps_def aux_def eq[symmetric] rc_def ‹0 < rc› D'_def proof (rule rec2) show "P (rc, data') D' (ab gs bs hs data') (ap gs bs (ps -- sps) hs data') (gb_schema_dummy (rc, data') D' (ab gs bs hs data') (ap gs bs (ps -- sps) hs data'))" unfolding D'_def using False sps_def refl aux_def rc_def ‹rc ≠ 0› eq[symmetric] refl by (rule 1) qed qed qed qed qed lemma fst_gb_schema_dummy_dgrad_p_set_le: assumes "dickson_grading d" and "struct_spec sel ap ab compl" shows "dgrad_p_set_le d (fst ` set (fst (gb_schema_dummy data D bs ps))) (args_to_set (gs, bs, ps))" using assms(2) proof (induct rule: gb_schema_dummy_induct) case (base bs data D) show ?case by (simp add: args_to_set_def, rule dgrad_p_set_le_subset, fact subset_refl) next case (rec1 bs ps sps data D) show ?case proof (cases "fst ` set gs ∪ fst ` set bs ⊆ {0}") case True hence "Keys (fst ` set (gs @ bs)) = {}" by (auto simp add: image_Un Keys_def) hence "component_of_term ` Keys (fst ` set (full_gb (gs @ bs))) = {}" by (simp add: components_full_gb) hence "Keys (fst ` set (full_gb (gs @ bs))) = {}" by simp thus ?thesis by (simp add: dgrad_p_set_le_def dgrad_set_le_def) next case False from pps_full_gb have "dgrad_set_le d (pp_of_term ` Keys (fst ` set (full_gb (gs @ bs)))) {0}" by (rule dgrad_set_le_subset) also have "dgrad_set_le d ... (pp_of_term ` Keys (args_to_set (gs, bs, ps)))" proof (rule dgrad_set_leI, simp) from False have "Keys (args_to_set (gs, bs, ps)) ≠ {}" by (simp add: args_to_set_alt Keys_Un, metis Keys_not_empty singletonI subsetI) then obtain v where "v ∈ Keys (args_to_set (gs, bs, ps))" by blast moreover have "d 0 ≤ d (pp_of_term v)" by (simp add: assms(1) dickson_grading_adds_imp_le) ultimately show "∃t∈Keys (args_to_set (gs, bs, ps)). d 0 ≤ d (pp_of_term t)" .. qed finally show ?thesis by (simp add: dgrad_p_set_le_def) qed next case (rec2 bs ps sps aux hs rc data data' D D') from rec2(4) have "hs = fst (add_indices (compl gs bs (ps -- sps) sps (snd data)) (snd data))" unfolding rec2(3) by (metis fstI) with assms rec2(1, 2) have "dgrad_p_set_le d (args_to_set (gs, ab gs bs hs data', ap gs bs (ps -- sps) hs data')) (args_to_set (gs, bs, ps))" by (rule dgrad_p_set_le_args_to_set_struct) with rec2(8) show ?case by (rule dgrad_p_set_le_trans) qed lemma fst_gb_schema_dummy_components: assumes "struct_spec sel ap ab compl" and "set ps ⊆ (set bs) × (set gs ∪ set bs)" shows "component_of_term ` Keys (fst ` set (fst (gb_schema_dummy data D bs ps))) = component_of_term ` Keys (args_to_set (gs, bs, ps))" using assms proof (induct rule: gb_schema_dummy_induct) case (base bs data D) show ?case by (simp add: args_to_set_def) next case (rec1 bs ps sps data D) have "component_of_term ` Keys (fst ` set (full_gb (gs @ bs))) = component_of_term ` Keys (fst ` set (gs @ bs))" by (fact components_full_gb) also have "... = component_of_term ` Keys (args_to_set (gs, bs, ps))" by (simp add: args_to_set_subset_Times[OF rec1.prems] image_Un) finally show ?case by simp next case (rec2 bs ps sps aux hs rc data data' D D') from assms(1) have ap: "ap_spec ap" and ab: "ab_spec ab" by (rule struct_specD)+ from this rec2.prems have sub: "set (ap gs bs (ps -- sps) hs data') ⊆ set (ab gs bs hs data') × (set gs ∪ set (ab gs bs hs data'))" by (rule subset_Times_ap) from rec2(4) have hs: "hs = fst (add_indices (compl gs bs (ps -- sps) sps (snd data)) (snd data))" unfolding rec2(3) by (metis fstI) have "component_of_term ` Keys (args_to_set (gs, ab gs bs hs data', ap gs bs (ps -- sps) hs data')) = component_of_term ` Keys (args_to_set (gs, bs, ps))" (is "?l = ?r") proof from assms(1) rec2(1, 2) hs show "?l ⊆ ?r" by (rule components_subset_struct) next show "?r ⊆ ?l" by (simp add: args_to_set_subset_Times[OF rec2.prems] args_to_set_alt2[OF ap ab rec2.prems] image_Un, rule image_mono, rule Keys_mono, blast) qed with rec2.hyps(8)[OF sub] show ?case by (rule trans) qed lemma fst_gb_schema_dummy_pmdl: assumes "struct_spec sel ap ab compl" and "compl_pmdl compl" and "is_Groebner_basis (fst ` set gs)" and "set ps ⊆ set bs × (set gs ∪ set bs)" and "unique_idx (gs @ bs) (snd data)" and "rem_comps_spec (gs @ bs) data" shows "pmdl (fst ` set (fst (gb_schema_dummy data D bs ps))) = pmdl (fst ` set (gs @ bs))" proof - from assms(1) have sel: "sel_spec sel" and ap: "ap_spec ap" and ab: "ab_spec ab" and compl: "compl_struct compl" by (rule struct_specD)+ from assms(1, 4, 5, 6) show ?thesis proof (induct bs ps rule: gb_schema_dummy_induct) case (base bs data D) show ?case by simp next case (rec1 bs ps sps data D) define aux where "aux = compl gs bs (ps -- sps) sps (snd data)" define data' where "data' = snd (add_indices aux (snd data))" define hs where "hs = fst (add_indices aux (snd data))" have hs_data': "(hs, data') = add_indices aux (snd data)" by (simp add: hs_def data'_def) have eq: "set (gs @ ab gs bs hs data') = set (gs @ bs @ hs)" by (simp add: ab_specD1[OF ab]) from sel rec1(1) have "sps ≠ []" and "set sps ⊆ set ps" unfolding rec1(2) by (rule sel_specD1, rule sel_specD2) from full_gb_is_full_pmdl have "pmdl (fst ` set (full_gb (gs @ bs))) = pmdl (fst ` set (gs @ ab gs bs hs data'))" proof (rule is_full_pmdl_eq) show "is_full_pmdl (fst ` set (gs @ ab gs bs hs data'))" proof (rule is_full_pmdlI_lt_finite) from finite_set show "finite (fst ` set (gs @ ab gs bs hs data'))" by (rule finite_imageI) next fix k assume "k ∈ component_of_term ` Keys (fst ` set (gs @ ab gs bs hs data'))" hence "Some k ∈ Some ` component_of_term ` Keys (fst ` set (gs @ ab gs bs hs data'))" by simp also have "... = const_lt_component ` (fst ` set (gs @ ab gs bs hs data') - {0}) - {None}" (is "?A = ?B") proof (rule card_seteq[symmetric]) show "finite ?A" by (intro finite_imageI finite_Keys, fact finite_set) next have "rem_comps_spec (gs @ ab gs bs hs data') (fst data - count_const_lt_components (fst aux), data')" using assms(1) rec1.prems(3) rec1.hyps(1) rec1.prems(1) rec1.hyps(2) aux_def hs_data' by (rule rem_comps_spec_struct) also have "... = (0, data')" by (simp add: aux_def rec1.hyps(3)) finally have "card (const_lt_component ` (fst ` set (gs @ ab gs bs hs data') - {0}) - {None}) = card (component_of_term ` Keys (fst ` set (gs @ ab gs bs hs data')))" by (simp add: rem_comps_spec_def) also have "... = card (Some ` component_of_term ` Keys (fst ` set (gs @ ab gs bs hs data')))" by (rule card_image[symmetric], simp) finally show "card ?A ≤ card ?B" by simp qed (fact const_lt_component_subset) finally have "Some k ∈ const_lt_component ` (fst ` set (gs @ ab gs bs hs data') - {0})" by simp then obtain b where "b ∈ fst ` set (gs @ ab gs bs hs data')" and "b ≠ 0" and *: "const_lt_component b = Some k" by fastforce show "∃b∈fst ` set (gs @ ab gs bs hs data'). b ≠ 0 ∧ component_of_term (lt b) = k ∧ lp b = 0" proof (intro bexI conjI) from * show "component_of_term (lt b) = k" by (rule const_lt_component_SomeD2) next from * show "lp b = 0" by (rule const_lt_component_SomeD1) qed fact+ qed next from compl ‹sps ≠ []› ‹set sps ⊆ set ps› have "component_of_term ` Keys (fst ` set hs) ⊆ component_of_term ` Keys (args_to_set (gs, bs, ps))" unfolding hs_def aux_def fst_set_add_indices by (rule compl_structD2) hence sub: "component_of_term ` Keys (fst ` set hs) ⊆ component_of_term ` Keys (fst ` set (gs @ bs))" by (simp add: args_to_set_subset_Times[OF rec1.prems(1)] image_Un) have "component_of_term ` Keys (fst ` set (full_gb (gs @ bs))) = component_of_term ` Keys (fst ` set (gs @ bs))" by (fact components_full_gb) also have "... = component_of_term ` Keys (fst ` set ((gs @ bs) @ hs))" by (simp only: set_append[of _ hs] image_Un Keys_Un Un_absorb2 sub) finally show "component_of_term ` Keys (fst ` set (full_gb (gs @ bs))) = component_of_term ` Keys (fst ` set (gs @ ab gs bs hs data'))" by (simp only: eq append_assoc) qed also have "... = pmdl (fst ` set (gs @ bs))" using assms(1, 2, 3) rec1.hyps(1) rec1.prems(1, 2) rec1.hyps(2) aux_def hs_data' by (rule pmdl_struct) finally show ?case by simp next case (rec2 bs ps sps aux hs rc data data' D D') from rec2(4) have hs: "hs = fst (add_indices aux (snd data))" by (metis fstI) have "pmdl (fst ` set (fst (gb_schema_dummy (rc, data') D' (ab gs bs hs data') (ap gs bs (ps -- sps) hs data')))) = pmdl (fst ` set (gs @ ab gs bs hs data'))" proof (rule rec2.hyps(8)) from ap ab rec2.prems(1) show "set (ap gs bs (ps -- sps) hs data') ⊆ set (ab gs bs hs data') × (set gs ∪ set (ab gs bs hs data'))" by (rule subset_Times_ap) next from ab rec2.prems(2) rec2(4) show "unique_idx (gs @ ab gs bs hs data') (snd (rc, data'))" unfolding snd_conv by (rule unique_idx_ab) next show "rem_comps_spec (gs @ ab gs bs hs data') (rc, data')" unfolding rec2.hyps(5) using assms(1) rec2.prems(3) rec2.hyps(1) rec2.prems(1) rec2.hyps(2, 3, 4) by (rule rem_comps_spec_struct) qed also have "... = pmdl (fst ` set (gs @ bs))" using assms(1, 2, 3) rec2.hyps(1) rec2.prems(1, 2) rec2.hyps(2, 3, 4) by (rule pmdl_struct) finally show ?case . qed qed lemma snd_gb_schema_dummy_subset: assumes "struct_spec sel ap ab compl" and "set ps ⊆ set bs × (set gs ∪ set bs)" and "D ⊆ (set gs ∪ set bs) × (set gs ∪ set bs)" and "res = gb_schema_dummy data D bs ps" shows "snd res ⊆ set (fst res) × set (fst res) ∨ (∃xs. fst (res) = full_gb xs)" using assms proof (induct data D bs ps rule: gb_schema_dummy_induct) case (base bs data D) from base(2) show ?case by (simp add: base(3)) next case (rec1 bs ps sps data D) have "∃xs. fst res = full_gb xs" by (auto simp: rec1(6)) thus ?case .. next case (rec2 bs ps sps aux hs rc data data' D D') from assms(1) have ab: "ab_spec ab" and ap: "ap_spec ap" by (rule struct_specD)+ from _ _ rec2.prems(3) show ?case proof (rule rec2.hyps(8)) from ap ab rec2.prems(1) show "set (ap gs bs (ps -- sps) hs data') ⊆ set (ab gs bs hs data') × (set gs ∪ set (ab gs bs hs data'))" by (rule subset_Times_ap) next from ab rec2.hyps(7) rec2.prems(1) rec2.prems(2) show "D' ⊆ (set gs ∪ set (ab gs bs hs data')) × (set gs ∪ set (ab gs bs hs data'))" by (rule discarded_subset) qed qed lemma gb_schema_dummy_connectible1: assumes "struct_spec sel ap ab compl" and "compl_conn compl" and "dickson_grading d" and "fst ` set gs ⊆ dgrad_p_set d m" and "is_Groebner_basis (fst ` set gs)" and "fst ` set bs ⊆ dgrad_p_set d m" and "set ps ⊆ set bs × (set gs ∪ set bs)" and "unique_idx (gs @ bs) (snd data)" and "⋀p q. processed (p, q) (gs @ bs) ps ⟹ (p, q) ∉⇩p D ⟹ fst p ≠ 0 ⟹ fst q ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs)) (fst p) (fst q)" and "¬(∃xs. fst (gb_schema_dummy data D bs ps) = full_gb xs)" assumes "f ∈ set (fst (gb_schema_dummy data D bs ps))" and "g ∈ set (fst (gb_schema_dummy data D bs ps))" and "(f, g) ∉⇩p snd (gb_schema_dummy data D bs ps)" and "fst f ≠ 0" and "fst g ≠ 0" shows "crit_pair_cbelow_on d m (fst ` set (fst (gb_schema_dummy data D bs ps))) (fst f) (fst g)" using assms(1, 6, 7, 8, 9, 10, 11, 12, 13) proof (induct data D bs ps rule: gb_schema_dummy_induct) case (base bs data D) show ?case proof (cases "f ∈ set gs") case True show ?thesis proof (cases "g ∈ set gs") case True note assms(3, 4, 5) moreover from ‹f ∈ set gs› have "fst f ∈ fst ` set gs" by simp moreover from ‹g ∈ set gs› have "fst g ∈ fst ` set gs" by simp ultimately have "crit_pair_cbelow_on d m (fst ` set gs) (fst f) (fst g)" using assms(14, 15) by (rule GB_imp_crit_pair_cbelow_dgrad_p_set) moreover have "fst ` set gs ⊆ fst ` set (fst (gs @ bs, D))" by auto ultimately show ?thesis by (rule crit_pair_cbelow_mono) next case False from this base(6, 7) have "processed (g, f) (gs @ bs) []" by (simp add: processed_Nil) moreover from base.prems(8) have "(g, f) ∉⇩p D" by (simp add: in_pair_iff) ultimately have "crit_pair_cbelow_on d m (fst ` set (gs @ bs)) (fst g) (fst f)" using ‹fst g ≠ 0› ‹fst f ≠ 0› unfolding set_append by (rule base(4)) thus ?thesis unfolding fst_conv by (rule crit_pair_cbelow_sym) qed next case False from this base(6, 7) have "processed (f, g) (gs @ bs) []" by (simp add: processed_Nil) moreover from base.prems(8) have "(f, g) ∉⇩p D" by simp ultimately show ?thesis unfolding fst_conv set_append using ‹fst f ≠ 0› ‹fst g ≠ 0› by (rule base(4)) qed next case (rec1 bs ps sps data D) from rec1.prems(5) show ?case by auto next case (rec2 bs ps sps aux hs rc data data' D D') from rec2.hyps(4) have hs: "hs = fst (add_indices aux (snd data))" by (metis fstI) from assms(1) have sel: "sel_spec sel" and ap: "ap_spec ap" and ab: "ab_spec ab" and compl: "compl_struct compl" by (rule struct_specD1, rule struct_specD2, rule struct_specD3, rule struct_specD4) from sel rec2.hyps(1) have "sps ≠ []" and "set sps ⊆ set ps" unfolding rec2.hyps(2) by (rule sel_specD1, rule sel_specD2) from ap ab rec2.prems(2) have ap_sub: "set (ap gs bs (ps -- sps) hs data') ⊆ set (ab gs bs hs data') × (set gs ∪ set (ab gs bs hs data'))" by (rule subset_Times_ap) have ns_sub: "fst ` set hs ⊆ dgrad_p_set d m" proof (rule dgrad_p_set_le_dgrad_p_set) from compl assms(3) ‹sps ≠ []› ‹set sps ⊆ set ps› show "dgrad_p_set_le d (fst ` set hs) (args_to_set (gs, bs, ps))" unfolding hs rec2.hyps(3) fst_set_add_indices by (rule compl_structD1) next from assms(4) rec2.prems(1) show "args_to_set (gs, bs, ps) ⊆ dgrad_p_set d m" by (simp add: args_to_set_subset_Times[OF rec2.prems(2)]) qed with rec2.prems(1) have ab_sub: "fst ` set (ab gs bs hs data') ⊆ dgrad_p_set d m" by (auto simp add: ab_specD1[OF ab]) have cpq: "(p, q) ∈⇩p set sps ⟹ fst p ≠ 0 ⟹ fst q ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` (set gs ∪ set (ab gs bs hs data'))) (fst p) (fst q)" for p q proof - assume "(p, q) ∈⇩p set sps" and "fst p ≠ 0" and "fst q ≠ 0" from this(1) have "(p, q) ∈ set sps ∨ (q, p) ∈ set sps" by (simp only: in_pair_iff) hence "crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs) ∪ fst ` set (fst (compl gs bs (ps -- sps) sps (snd data)))) (fst p) (fst q)" proof assume "(p, q) ∈ set sps" from assms(2, 3, 4, 5) rec2.prems(1, 2) ‹sps ≠ []› ‹set sps ⊆ set ps› rec2.prems(3) this ‹fst p ≠ 0› ‹fst q ≠ 0› show ?thesis by (rule compl_connD) next assume "(q, p) ∈ set sps" from assms(2, 3, 4, 5) rec2.prems(1, 2) ‹sps ≠ []› ‹set sps ⊆ set ps› rec2.prems(3) this ‹fst q ≠ 0› ‹fst p ≠ 0› have "crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs) ∪ fst ` set (fst (compl gs bs (ps -- sps) sps (snd data)))) (fst q) (fst p)" by (rule compl_connD) thus ?thesis by (rule crit_pair_cbelow_sym) qed thus "crit_pair_cbelow_on d m (fst ` (set gs ∪ set (ab gs bs hs data'))) (fst p) (fst q)" by (simp add: ab_specD1[OF ab] hs rec2.hyps(3) fst_set_add_indices image_Un Un_assoc) qed from ab_sub ap_sub _ _ rec2.prems(5, 6, 7, 8) show ?case proof (rule rec2.hyps(8)) from ab rec2.prems(3) rec2(4) show "unique_idx (gs @ ab gs bs hs data') (snd (rc, data'))" unfolding snd_conv by (rule unique_idx_ab) next fix p q :: "('t, 'b, 'c) pdata" define ps' where "ps' = ap gs bs (ps -- sps) hs data'" assume "fst p ≠ 0" and "fst q ≠ 0" and "(p, q) ∉⇩p D'" assume "processed (p, q) (gs @ ab gs bs hs data') ps'" hence p_in: "p ∈ set gs ∪ set bs ∪ set hs" and q_in: "q ∈ set gs ∪ set bs ∪ set hs" and "(p, q) ∉⇩p set ps'" by (simp_all add: processed_alt ab_specD1[OF ab]) from this(3) ‹(p, q) ∉⇩p D'› have "(p, q) ∉⇩p D" and "(p, q) ∉⇩p set (ps -- sps)" and "(p, q) ∉⇩p set hs × (set gs ∪ set bs ∪ set hs)" by (auto simp: in_pair_iff rec2.hyps(7) ps'_def) from this(3) p_in q_in have "p ∈ set gs ∪ set bs" and "q ∈ set gs ∪ set bs" by (meson SigmaI UnE in_pair_iff)+ show "crit_pair_cbelow_on d m (fst ` (set gs ∪ set (ab gs bs hs data'))) (fst p) (fst q)" proof (cases "component_of_term (lt (fst p)) = component_of_term (lt (fst q))") case True show ?thesis proof (cases "(p, q) ∈⇩p set sps") case True from this ‹fst p ≠ 0› ‹fst q ≠ 0› show ?thesis by (rule cpq) next case False with ‹(p, q) ∉⇩p set (ps -- sps)› have "(p, q) ∉⇩p set ps" by (auto simp: in_pair_iff set_diff_list) with ‹p ∈ set gs ∪ set bs› ‹q ∈ set gs ∪ set bs› have "processed (p, q) (gs @ bs) ps" by (simp add: processed_alt) from this ‹(p, q) ∉⇩p D› ‹fst p ≠ 0› ‹fst q ≠ 0› have "crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs)) (fst p) (fst q)" by (rule rec2.prems(4)) moreover have "fst ` (set gs ∪ set bs) ⊆ fst ` (set gs ∪ set (ab gs bs hs data'))" by (auto simp: ab_specD1[OF ab]) ultimately show ?thesis by (rule crit_pair_cbelow_mono) qed next case False thus ?thesis by (rule crit_pair_cbelow_distinct_component) qed qed qed lemma gb_schema_dummy_connectible2: assumes "struct_spec sel ap ab compl" and "compl_conn compl" and "dickson_grading d" and "fst ` set gs ⊆ dgrad_p_set d m" and "is_Groebner_basis (fst ` set gs)" and "fst ` set bs ⊆ dgrad_p_set d m" and "set ps ⊆ set bs × (set gs ∪ set bs)" and "D ⊆ (set gs ∪ set bs) × (set gs ∪ set bs)" and "set ps ∩⇩p D = {}" and "unique_idx (gs @ bs) (snd data)" and "⋀B a b. set gs ∪ set bs ⊆ B ⟹ fst ` B ⊆ dgrad_p_set d m ⟹ (a, b) ∈⇩p D ⟹ fst a ≠ 0 ⟹ fst b ≠ 0 ⟹ (⋀x y. x ∈ set gs ∪ set bs ⟹ y ∈ set gs ∪ set bs ⟹ ¬ (x, y) ∈⇩p D ⟹ fst x ≠ 0 ⟹ fst y ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst x) (fst y)) ⟹ crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)" and "⋀x y. x ∈ set (fst (gb_schema_dummy data D bs ps)) ⟹ y ∈ set (fst (gb_schema_dummy data D bs ps)) ⟹ (x, y) ∉⇩p snd (gb_schema_dummy data D bs ps) ⟹ fst x ≠ 0 ⟹ fst y ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` set (fst (gb_schema_dummy data D bs ps))) (fst x) (fst y)" and "¬(∃xs. fst (gb_schema_dummy data D bs ps) = full_gb xs)" assumes "(f, g) ∈⇩p snd (gb_schema_dummy data D bs ps)" and "fst f ≠ 0" and "fst g ≠ 0" shows "crit_pair_cbelow_on d m (fst ` set (fst (gb_schema_dummy data D bs ps))) (fst f) (fst g)" using assms(1, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16) proof (induct data D bs ps rule: gb_schema_dummy_induct) case (base bs data D) have "set gs ∪ set bs ⊆ set (fst (gs @ bs, D))" by simp moreover from assms(4) base.prems(1) have "fst ` set (fst (gs @ bs, D)) ⊆ dgrad_p_set d m" by auto moreover from base.prems(9) have "(f, g) ∈⇩p D" by simp moreover note assms(15, 16) ultimately show ?case proof (rule base.prems(6)) fix x y assume "x ∈ set gs ∪ set bs" and "y ∈ set gs ∪ set bs" and "(x, y) ∉⇩p D" hence "x ∈ set (fst (gs @ bs, D))" and "y ∈ set (fst (gs @ bs, D))" and "(x, y) ∉⇩p snd (gs @ bs, D)" by simp_all moreover assume "fst x ≠ 0" and "fst y ≠ 0" ultimately show "crit_pair_cbelow_on d m (fst ` set (fst (gs @ bs, D))) (fst x) (fst y)" by (rule base.prems(7)) qed next case (rec1 bs ps sps data D) from rec1.prems(8) show ?case by auto next case (rec2 bs ps sps aux hs rc data data' D D') from rec2.hyps(4) have hs: "hs = fst (add_indices aux (snd data))" by (metis fstI) from assms(1) have sel: "sel_spec sel" and ap: "ap_spec ap" and ab: "ab_spec ab" and compl: "compl_struct compl" by (rule struct_specD)+ let ?X = "set (ps -- sps) ∪ set hs × (set gs ∪ set bs ∪ set hs)" from sel rec2.hyps(1) have "sps ≠ []" and "set sps ⊆ set ps" unfolding rec2.hyps(2) by (rule sel_specD1, rule sel_specD2) have "fst ` set hs ∩ fst ` (set gs ∪ set bs) = {}" unfolding hs fst_set_add_indices rec2.hyps(3) using compl ‹sps ≠ []› ‹set sps ⊆ set ps› by (rule compl_struct_disjoint) hence disj1: "(set gs ∪ set bs) ∩ set hs = {}" by fastforce have disj2: "set (ap gs bs (ps -- sps) hs data') ∩⇩p D' = {}" proof (rule, rule) fix x y assume "(x, y) ∈ set (ap gs bs (ps -- sps) hs data') ∩⇩p D'" hence "(x, y) ∈⇩p set (ap gs bs (ps -- sps) hs data') ∩⇩p D'" by (simp add: in_pair_alt) hence 1: "(x, y) ∈⇩p set (ap gs bs (ps -- sps) hs data')" and "(x, y) ∈⇩p D'" by simp_all hence "(x, y) ∈⇩p D" by (simp add: rec2.hyps(7)) from this rec2.prems(3) have "x ∈ set gs ∪ set bs" and "y ∈ set gs ∪ set bs" by (auto simp: in_pair_iff) from 1 ap_specD1[OF ap] have "(x, y) ∈⇩p ?X" by (rule in_pair_trans) thus "(x, y) ∈ {}" unfolding in_pair_Un proof assume "(x, y) ∈⇩p set (ps -- sps)" also have "... ⊆ set ps" by (auto simp: set_diff_list) finally have "(x, y) ∈⇩p set ps ∩⇩p D" using ‹(x, y) ∈⇩p D› by simp also have "... = {}" by (fact rec2.prems(4)) finally show ?thesis by (simp add: in_pair_iff) next assume "(x, y) ∈⇩p set hs × (set gs ∪ set bs ∪ set hs)" hence "x ∈ set hs ∨ y ∈ set hs" by (auto simp: in_pair_iff) thus ?thesis proof assume "x ∈ set hs" with ‹x ∈ set gs ∪ set bs› have "x ∈ (set gs ∪ set bs) ∩ set hs" .. thus ?thesis by (simp add: disj1) next assume "y ∈ set hs" with ‹y ∈ set gs ∪ set bs› have "y ∈ (set gs ∪ set bs) ∩ set hs" .. thus ?thesis by (simp add: disj1) qed qed qed simp have hs_sub: "fst ` set hs ⊆ dgrad_p_set d m" proof (rule dgrad_p_set_le_dgrad_p_set) from compl assms(3) ‹sps ≠ []› ‹set sps ⊆ set ps› show "dgrad_p_set_le d (fst ` set hs) (args_to_set (gs, bs, ps))" unfolding hs rec2.hyps(3) fst_set_add_indices by (rule compl_structD1) next from assms(4) rec2.prems(1) show "args_to_set (gs, bs, ps) ⊆ dgrad_p_set d m" by (simp add: args_to_set_subset_Times[OF rec2.prems(2)]) qed with rec2.prems(1) have ab_sub: "fst ` set (ab gs bs hs data') ⊆ dgrad_p_set d m" by (auto simp add: ab_specD1[OF ab]) moreover from ap ab rec2.prems(2) have ap_sub: "set (ap gs bs (ps -- sps) hs data') ⊆ set (ab gs bs hs data') × (set gs ∪ set (ab gs bs hs data'))" by (rule subset_Times_ap) moreover from ab rec2.hyps(7) rec2.prems(2) rec2.prems(3) have "D' ⊆ (set gs ∪ set (ab gs bs hs data')) × (set gs ∪ set (ab gs bs hs data'))" by (rule discarded_subset) moreover note disj2 moreover from ab rec2.prems(5) rec2.hyps(4) have uid: "unique_idx (gs @ ab gs bs hs data') (snd (rc, data'))" unfolding snd_conv by (rule unique_idx_ab) ultimately show ?case using _ _ rec2.prems(8, 9, 10, 11) proof (rule rec2.hyps(8), simp only: ab_specD1[OF ab] Un_assoc[symmetric]) define ps' where "ps' = ap gs bs (ps -- sps) hs data'" fix B a b assume B_sup: "set gs ∪ set bs ∪ set hs ⊆ B" hence "set gs ∪ set bs ⊆ B" and "set hs ⊆ B" by simp_all assume "(a, b) ∈⇩p D'" hence ab_cases: "(a, b) ∈⇩p D ∨ (a, b) ∈⇩p set hs × (set gs ∪ set bs ∪ set hs) -⇩p set ps' ∨ (a, b) ∈⇩p set (ps -- sps) -⇩p set ps'" by (auto simp: rec2.hyps(7) ps'_def) assume B_sub: "fst ` B ⊆ dgrad_p_set d m" and "fst a ≠ 0" and "fst b ≠ 0" assume *: "⋀x y. x ∈ set gs ∪ set bs ∪ set hs ⟹ y ∈ set gs ∪ set bs ∪ set hs ⟹ (x, y) ∉⇩p D' ⟹ fst x ≠ 0 ⟹ fst y ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst x) (fst y)" from rec2.prems(2) have ps_sps_sub: "set (ps -- sps) ⊆ set bs × (set gs ∪ set bs)" by (auto simp: set_diff_list) from uid have uid': "unique_idx (gs @ bs @ hs) data'" by (simp add: unique_idx_def ab_specD1[OF ab]) have a: "crit_pair_cbelow_on d m (fst ` B) (fst x) (fst y)" if "fst x ≠ 0" and "fst y ≠ 0" and xy_in: "(x, y) ∈⇩p set (ps -- sps) -⇩p set ps'" for x y proof (cases "x = y") case True from xy_in rec2.prems(2) have "y ∈ set gs ∪ set bs" unfolding in_pair_minus_pairs unfolding True in_pair_iff set_diff_list by auto hence "fst y ∈ fst ` set gs ∪ fst ` set bs" by fastforce from this assms(4) rec2.prems(1) have "fst y ∈ dgrad_p_set d m" by blast with assms(3) show ?thesis unfolding True by (rule crit_pair_cbelow_same) next case False from ap assms(3) B_sup B_sub ps_sps_sub disj1 uid' assms(5) False ‹fst x ≠ 0› ‹fst y ≠ 0› xy_in show ?thesis unfolding ps'_def proof (rule ap_specD3) fix a1 b1 :: "('t, 'b, 'c) pdata" assume "fst a1 ≠ 0" and "fst b1 ≠ 0" assume "a1 ∈ set hs" and b1_in: "b1 ∈ set gs ∪ set bs ∪ set hs" hence a1_in: "a1 ∈ set gs ∪ set bs ∪ set hs" by fastforce assume "(a1, b1) ∈⇩p set (ap gs bs (ps -- sps) hs data')" hence "(a1, b1) ∈⇩p set ps'" by (simp only: ps'_def) with disj2 have "(a1, b1) ∉⇩p D'" unfolding ps'_def by (metis empty_iff in_pair_Int_pairs in_pair_alt) with a1_in b1_in show "crit_pair_cbelow_on d m (fst ` B) (fst a1) (fst b1)" using ‹fst a1 ≠ 0› ‹fst b1 ≠ 0› by (rule *) qed qed have b: "crit_pair_cbelow_on d m (fst ` B) (fst x) (fst y)" if "(x, y) ∈⇩p D" and "fst x ≠ 0" and "fst y ≠ 0" for x y using ‹set gs ∪ set bs ⊆ B› B_sub that proof (rule rec2.prems(6)) fix a1 b1 :: "('t, 'b, 'c) pdata" assume "a1 ∈ set gs ∪ set bs" and "b1 ∈ set gs ∪ set bs" hence a1_in: "a1 ∈ set gs ∪ set bs ∪ set hs" and b1_in: "b1 ∈ set gs ∪ set bs ∪ set hs" by fastforce+ assume "(a1, b1) ∉⇩p D" and "fst a1 ≠ 0" and "fst b1 ≠ 0" show "crit_pair_cbelow_on d m (fst ` B) (fst a1) (fst b1)" proof (cases "(a1, b1) ∈⇩p ?X -⇩p set ps'") case True moreover from ‹a1 ∈ set gs ∪ set bs› ‹b1 ∈ set gs ∪ set bs› disj1 have "(a1, b1) ∉⇩p set hs × (set gs ∪ set bs ∪ set hs)" by (auto simp: in_pair_def) ultimately have "(a1, b1) ∈⇩p set (ps -- sps) -⇩p set ps'" by auto with ‹fst a1 ≠ 0› ‹fst b1 ≠ 0› show ?thesis by (rule a) next case False with ‹(a1, b1) ∉⇩p D› have "(a1, b1) ∉⇩p D'" by (auto simp: rec2.hyps(7) ps'_def) with a1_in b1_in show ?thesis using ‹fst a1 ≠ 0› ‹fst b1 ≠ 0› by (rule *) qed qed have c: "crit_pair_cbelow_on d m (fst ` B) (fst x) (fst y)" if x_in: "x ∈ set gs ∪ set bs ∪ set hs" and y_in: "y ∈ set gs ∪ set bs ∪ set hs" and xy: "(x, y) ∉⇩p (?X -⇩p set ps')" and "fst x ≠ 0" and "fst y ≠ 0" for x y proof (cases "(x, y) ∈⇩p D") case True thus ?thesis using ‹fst x ≠ 0› ‹fst y ≠ 0› by (rule b) next case False with xy have "(x, y) ∉⇩p D'" unfolding rec2.hyps(7) ps'_def by auto with x_in y_in show ?thesis using ‹fst x ≠ 0› ‹fst y ≠ 0› by (rule *) qed from ab_cases show "crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)" proof (elim disjE) assume "(a, b) ∈⇩p D" thus ?thesis using ‹fst a ≠ 0› ‹fst b ≠ 0› by (rule b) next assume ab_in: "(a, b) ∈⇩p set hs × (set gs ∪ set bs ∪ set hs) -⇩p set ps'" hence ab_in': "(a, b) ∈⇩p set hs × (set gs ∪ set bs ∪ set hs)" and "(a, b) ∉⇩p set ps'" by simp_all show ?thesis proof (cases "a = b") case True from ab_in' rec2.prems(2) have "b ∈ set hs" unfolding True in_pair_iff set_diff_list by auto hence "fst b ∈ fst ` set hs" by fastforce from this hs_sub have "fst b ∈ dgrad_p_set d m" .. with assms(3) show ?thesis unfolding True by (rule crit_pair_cbelow_same) next case False from ap assms(3) B_sup B_sub ab_in' ps_sps_sub uid' assms(5) False ‹fst a ≠ 0› ‹fst b ≠ 0› show ?thesis proof (rule ap_specD2) fix x y :: "('t, 'b, 'c) pdata" assume "(x, y) ∈⇩p set (ap gs bs (ps -- sps) hs data')" also from ap_sub have "... ⊆ (set bs ∪ set hs) × (set gs ∪ set bs ∪ set hs)" by (simp only: ab_specD1[OF ab] Un_assoc) also have "... ⊆ (set gs ∪ set bs ∪ set hs) × (set gs ∪ set bs ∪ set hs)" by fastforce finally have "(x, y) ∈ (set gs ∪ set bs ∪ set hs) × (set gs ∪ set bs ∪ set hs)" unfolding in_pair_same . hence "x ∈ set gs ∪ set bs ∪ set hs" and "y ∈ set gs ∪ set bs ∪ set hs" by simp_all moreover from ‹(x, y) ∈⇩p set (ap gs bs (ps -- sps) hs data')› have "(x, y) ∉⇩p ?X -⇩p set ps'" by (simp add: ps'_def) moreover assume "fst x ≠ 0" and "fst y ≠ 0" ultimately show "crit_pair_cbelow_on d m (fst ` B) (fst x) (fst y)" by (rule c) next fix x y :: "('t, 'b, 'c) pdata" assume "fst x ≠ 0" and "fst y ≠ 0" assume 1: "x ∈ set gs ∪ set bs" and 2: "y ∈ set gs ∪ set bs" hence x_in: "x ∈ set gs ∪ set bs ∪ set hs" and y_in: "y ∈ set gs ∪ set bs ∪ set hs" by simp_all show "crit_pair_cbelow_on d m (fst ` B) (fst x) (fst y)" proof (cases "(x, y) ∈⇩p set (ps -- sps) -⇩p set ps'") case True with ‹fst x ≠ 0› ‹fst y ≠ 0› show ?thesis by (rule a) next case False have "(x, y) ∉⇩p set (ps -- sps) ∪ set hs × (set gs ∪ set bs ∪ set hs) -⇩p set ps'" proof assume "(x, y) ∈⇩p set (ps -- sps) ∪ set hs × (set gs ∪ set bs ∪ set hs) -⇩p set ps'" hence "(x, y) ∈⇩p set hs × (set gs ∪ set bs ∪ set hs)" using False by simp hence "x ∈ set hs ∨ y ∈ set hs" by (auto simp: in_pair_iff) with 1 2 disj1 show False by blast qed with x_in y_in show ?thesis using ‹fst x ≠ 0› ‹fst y ≠ 0› by (rule c) qed qed qed next assume "(a, b) ∈⇩p set (ps -- sps) -⇩p set ps'" with ‹fst a ≠ 0› ‹fst b ≠ 0› show ?thesis by (rule a) qed next fix x y :: "('t, 'b, 'c) pdata" let ?res = "gb_schema_dummy (rc, data') D' (ab gs bs hs data') (ap gs bs (ps -- sps) hs data')" assume "x ∈ set (fst ?res)" and "y ∈ set (fst ?res)" and "(x, y) ∉⇩p snd ?res" and "fst x ≠ 0" and "fst y ≠ 0" thus "crit_pair_cbelow_on d m (fst ` set (fst ?res)) (fst x) (fst y)" by (rule rec2.prems(7)) qed qed corollary gb_schema_dummy_connectible: assumes "struct_spec sel ap ab compl" and "compl_conn compl" and "dickson_grading d" and "fst ` set gs ⊆ dgrad_p_set d m" and "is_Groebner_basis (fst ` set gs)" and "fst ` set bs ⊆ dgrad_p_set d m" and "set ps ⊆ set bs × (set gs ∪ set bs)" and "D ⊆ (set gs ∪ set bs) × (set gs ∪ set bs)" and "set ps ∩⇩p D = {}" and "unique_idx (gs @ bs) (snd data)" and "⋀p q. processed (p, q) (gs @ bs) ps ⟹ (p, q) ∉⇩p D ⟹ fst p ≠ 0 ⟹ fst q ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs)) (fst p) (fst q)" and "⋀B a b. set gs ∪ set bs ⊆ B ⟹ fst ` B ⊆ dgrad_p_set d m ⟹ (a, b) ∈⇩p D ⟹ fst a ≠ 0 ⟹ fst b ≠ 0 ⟹ (⋀x y. x ∈ set gs ∪ set bs ⟹ y ∈ set gs ∪ set bs ⟹ ¬ (x, y) ∈⇩p D ⟹ fst x ≠ 0 ⟹ fst y ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst x) (fst y)) ⟹ crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)" assumes "f ∈ set (fst (gb_schema_dummy data D bs ps))" and "g ∈ set (fst (gb_schema_dummy data D bs ps))" and "fst f ≠ 0" and "fst g ≠ 0" shows "crit_pair_cbelow_on d m (fst ` set (fst (gb_schema_dummy data D bs ps))) (fst f) (fst g)" proof (cases "∃xs. fst (gb_schema_dummy data D bs ps) = full_gb xs") case True then obtain xs where xs: "fst (gb_schema_dummy data D bs ps) = full_gb xs" .. note assms(3) moreover have "fst ` set (full_gb xs) ⊆ dgrad_p_set d m" proof (rule dgrad_p_set_le_dgrad_p_set) have "dgrad_p_set_le d (fst ` set (full_gb xs)) (args_to_set (gs, bs, ps))" unfolding xs[symmetric] using assms(3, 1) by (rule fst_gb_schema_dummy_dgrad_p_set_le) also from assms(7) have "... = fst ` set gs ∪ fst ` set bs" by (rule args_to_set_subset_Times) finally show "dgrad_p_set_le d (fst ` set (full_gb xs)) (fst ` set gs ∪ fst ` set bs)" . next from assms(4, 6) show "fst ` set gs ∪ fst ` set bs ⊆ dgrad_p_set d m" by blast qed moreover note full_gb_isGB moreover from assms(13) have "fst f ∈ fst ` set (full_gb xs)" by (simp add: xs) moreover from assms(14) have "fst g ∈ fst ` set (full_gb xs)" by (simp add: xs) ultimately show ?thesis using assms(15, 16) unfolding xs by (rule GB_imp_crit_pair_cbelow_dgrad_p_set) next case not_full: False show ?thesis proof (cases "(f, g) ∈⇩p snd (gb_schema_dummy data D bs ps)") case True from assms(1-10,12) _ not_full True assms(15,16) show ?thesis proof (rule gb_schema_dummy_connectible2) fix x y assume "x ∈ set (fst (gb_schema_dummy data D bs ps))" and "y ∈ set (fst (gb_schema_dummy data D bs ps))" and "(x, y) ∉⇩p snd (gb_schema_dummy data D bs ps)" and "fst x ≠ 0" and "fst y ≠ 0" with assms(1-7,10,11) not_full show "crit_pair_cbelow_on d m (fst ` set (fst (gb_schema_dummy data D bs ps))) (fst x) (fst y)" by (rule gb_schema_dummy_connectible1) qed next case False from assms(1-7,10,11) not_full assms(13,14) False assms(15,16) show ?thesis by (rule gb_schema_dummy_connectible1) qed qed lemma fst_gb_schema_dummy_dgrad_p_set_le_init: assumes "dickson_grading d" and "struct_spec sel ap ab compl" shows "dgrad_p_set_le d (fst ` set (fst (gb_schema_dummy data D (ab gs [] bs (snd data)) (ap gs [] [] bs (snd data))))) (fst ` (set gs ∪ set bs))" proof - let ?bs = "ab gs [] bs (snd data)" from assms(2) have ap: "ap_spec ap" and ab: "ab_spec ab" by (rule struct_specD)+ from ap_specD1[OF ap, of gs "[]" "[]" bs] have *: "set (ap gs [] [] bs (snd data)) ⊆ set ?bs × (set gs ∪ set ?bs)" by (simp add: ab_specD1[OF ab]) from assms have "dgrad_p_set_le d (fst ` set (fst (gb_schema_dummy data D ?bs (ap gs [] [] bs (snd data))))) (args_to_set (gs, ?bs, (ap gs [] [] bs (snd data))))" by (rule fst_gb_schema_dummy_dgrad_p_set_le) also have "... = fst ` (set gs ∪ set bs)" by (simp add: args_to_set_subset_Times[OF *] image_Un ab_specD1[OF ab]) finally show ?thesis . qed corollary fst_gb_schema_dummy_dgrad_p_set_init: assumes "dickson_grading d" and "struct_spec sel ap ab compl" and "fst ` (set gs ∪ set bs) ⊆ dgrad_p_set d m" shows "fst ` set (fst (gb_schema_dummy (rc, data) D (ab gs [] bs data) (ap gs [] [] bs data))) ⊆ dgrad_p_set d m" proof (rule dgrad_p_set_le_dgrad_p_set) let ?data = "(rc, data)" from assms(1, 2) have "dgrad_p_set_le d (fst ` set (fst (gb_schema_dummy ?data D (ab gs [] bs (snd ?data)) (ap gs [] [] bs (snd ?data))))) (fst ` (set gs ∪ set bs))" by (rule fst_gb_schema_dummy_dgrad_p_set_le_init) thus "dgrad_p_set_le d (fst ` set (fst (gb_schema_dummy ?data D (ab gs [] bs data) (ap gs [] [] bs data)))) (fst ` (set gs ∪ set bs))" by (simp only: snd_conv) qed fact lemma fst_gb_schema_dummy_components_init: fixes bs data defines "bs0 ≡ ab gs [] bs data" defines "ps0 ≡ ap gs [] [] bs data" assumes "struct_spec sel ap ab compl" shows "component_of_term ` Keys (fst ` set (fst (gb_schema_dummy (rc, data) D bs0 ps0))) = component_of_term ` Keys (fst ` set (gs @ bs))" (is "?l = ?r") proof - from assms(3) have ap: "ap_spec ap" and ab: "ab_spec ab" by (rule struct_specD)+ from ap_specD1[OF ap, of gs "[]" "[]" bs] have *: "set ps0 ⊆ set bs0 × (set gs ∪ set bs0)" by (simp add: ps0_def bs0_def ab_specD1[OF ab]) with assms(3) have "?l = component_of_term ` Keys (args_to_set (gs, bs0, ps0))" by (rule fst_gb_schema_dummy_components) also have "... = ?r" by (simp only: args_to_set_subset_Times[OF *], simp add: ab_specD1[OF ab] bs0_def image_Un) finally show ?thesis . qed lemma fst_gb_schema_dummy_pmdl_init: fixes bs data defines "bs0 ≡ ab gs [] bs data" defines "ps0 ≡ ap gs [] [] bs data" assumes "struct_spec sel ap ab compl" and "compl_pmdl compl" and "is_Groebner_basis (fst ` set gs)" and "unique_idx (gs @ bs0) data" and "rem_comps_spec (gs @ bs0) (rc, data)" shows "pmdl (fst ` set (fst (gb_schema_dummy (rc, data) D bs0 ps0))) = pmdl (fst ` (set (gs @ bs)))" (is "?l = ?r") proof - from assms(3) have ab: "ab_spec ab" by (rule struct_specD3) let ?data = "(rc, data)" from assms(6) have "unique_idx (gs @ bs0) (snd ?data)" by (simp only: snd_conv) from assms(3, 4, 5) _ this assms(7) have "?l = pmdl (fst ` (set (gs @ bs0)))" proof (rule fst_gb_schema_dummy_pmdl) from assms(3) have "ap_spec ap" by (rule struct_specD2) from ap_specD1[OF this, of gs "[]" "[]" bs] show "set ps0 ⊆ set bs0 × (set gs ∪ set bs0)" by (simp add: ps0_def bs0_def ab_specD1[OF ab]) qed also have "... = ?r" by (simp add: bs0_def ab_specD1[OF ab]) finally show ?thesis . qed lemma fst_gb_schema_dummy_isGB_init: fixes bs data defines "bs0 ≡ ab gs [] bs data" defines "ps0 ≡ ap gs [] [] bs data" defines "D0 ≡ set bs × (set gs ∪ set bs) -⇩p set ps0" assumes "struct_spec sel ap ab compl" and "compl_conn compl" and "is_Groebner_basis (fst ` set gs)" and "unique_idx (gs @ bs0) data" and "rem_comps_spec (gs @ bs0) (rc, data)" shows "is_Groebner_basis (fst ` set (fst (gb_schema_dummy (rc, data) D0 bs0 ps0)))" proof - let ?data = "(rc, data)" let ?res = "gb_schema_dummy ?data D0 bs0 ps0" from assms(4) have ap: "ap_spec ap" and ab: "ab_spec ab" by (rule struct_specD2, rule struct_specD3) have set_bs0: "set bs0 = set bs" by (simp add: bs0_def ab_specD1[OF ab]) from ap_specD1[OF ap, of gs "[]" "[]" bs] have ps0_sub: "set ps0 ⊆ set bs0 × (set gs ∪ set bs0)" by (simp add: ps0_def set_bs0) from ex_dgrad obtain d::"'a ⇒ nat" where dg: "dickson_grading d" .. have "finite (fst ` (set gs ∪ set bs))" by (rule, rule finite_UnI, fact finite_set, fact finite_set) then obtain m where gs_bs_sub: "fst ` (set gs ∪ set bs) ⊆ dgrad_p_set d m" by (rule dgrad_p_set_exhaust) with dg assms(4) have "fst ` set (fst ?res) ⊆ dgrad_p_set d m" unfolding bs0_def ps0_def by (rule fst_gb_schema_dummy_dgrad_p_set_init) with dg show ?thesis proof (rule crit_pair_cbelow_imp_GB_dgrad_p_set) fix p0 q0 assume p0_in: "p0 ∈ fst ` set (fst ?res)" and q0_in: "q0 ∈ fst ` set (fst ?res)" assume "p0 ≠ 0" and "q0 ≠ 0" from ‹fst ` (set gs ∪ set bs) ⊆ dgrad_p_set d m› have "fst ` set gs ⊆ dgrad_p_set d m" and "fst ` set bs ⊆ dgrad_p_set d m" by (simp_all add: image_Un) from p0_in obtain p where p_in: "p ∈ set (fst ?res)" and p0: "p0 = fst p" .. from q0_in obtain q where q_in: "q ∈ set (fst ?res)" and q0: "q0 = fst q" .. from assms(7) have "unique_idx (gs @ bs0) (snd ?data)" by (simp only: snd_conv) from assms(4, 5) dg ‹fst ` set gs ⊆ dgrad_p_set d m› assms(6) _ ps0_sub _ _ this _ _ p_in q_in ‹p0 ≠ 0› ‹q0 ≠ 0› show "crit_pair_cbelow_on d m (fst ` set (fst ?res)) p0 q0" unfolding p0 q0 proof (rule gb_schema_dummy_connectible) from ‹fst ` set bs ⊆ dgrad_p_set d m› show "fst ` set bs0 ⊆ dgrad_p_set d m" by (simp only: set_bs0) next have "D0 ⊆ set bs × (set gs ∪ set bs)" by (auto simp: assms(3) minus_pairs_def) also have "... ⊆ (set gs ∪ set bs) × (set gs ∪ set bs)" by fastforce finally show "D0 ⊆ (set gs ∪ set bs0) × (set gs ∪ set bs0)" by (simp only: set_bs0) next show "set ps0 ∩⇩p D0 = {}" proof show "set ps0 ∩⇩p D0 ⊆ {}" proof fix x assume "x ∈ set ps0 ∩⇩p D0" hence "x ∈⇩p set ps0 ∩⇩p D0" by (simp add: in_pair_alt) thus "x ∈ {}" by (auto simp: assms(3)) qed qed simp next fix p' q' assume "processed (p', q') (gs @ bs0) ps0" hence proc: "processed (p', q') (gs @ bs) ps0" by (simp add: set_bs0 processed_alt) hence "p' ∈ set gs ∪ set bs" and "q' ∈ set gs ∪ set bs" and "(p', q') ∉⇩p set ps0" by (auto dest: processedD1 processedD2 processedD3) assume "(p', q') ∉⇩p D0" and "fst p' ≠ 0" and "fst q' ≠ 0" have "crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs)) (fst p') (fst q')" proof (cases "p' = q'") case True from dg show ?thesis unfolding True proof (rule crit_pair_cbelow_same) from ‹q' ∈ set gs ∪ set bs› have "fst q' ∈ fst ` (set gs ∪ set bs)" by simp from this ‹fst ` (set gs ∪ set bs) ⊆ dgrad_p_set d m› show "fst q' ∈ dgrad_p_set d m" .. qed next case False show ?thesis proof (cases "component_of_term (lt (fst p')) = component_of_term (lt (fst q'))") case True show ?thesis proof (cases "p' ∈ set gs ∧ q' ∈ set gs") case True note dg ‹fst ` set gs ⊆ dgrad_p_set d m› assms(6) moreover from True have "fst p' ∈ fst ` set gs" and "fst q' ∈ fst ` set gs" by simp_all ultimately have "crit_pair_cbelow_on d m (fst ` set gs) (fst p') (fst q')" using ‹fst p' ≠ 0› ‹fst q' ≠ 0› by (rule GB_imp_crit_pair_cbelow_dgrad_p_set) moreover have "fst ` set gs ⊆ fst ` (set gs ∪ set bs)" by blast ultimately show ?thesis by (rule crit_pair_cbelow_mono) next case False with ‹p' ∈ set gs ∪ set bs› ‹q' ∈ set gs ∪ set bs› have "(p', q') ∈⇩p set bs × (set gs ∪ set bs)" by (auto simp: in_pair_iff) with ‹(p', q') ∉⇩p D0› have "(p', q') ∈⇩p set ps0" by (simp add: assms(3)) with ‹(p', q') ∉⇩p set ps0› show ?thesis .. qed next case False thus ?thesis by (rule crit_pair_cbelow_distinct_component) qed qed thus "crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs0)) (fst p') (fst q')" by (simp only: set_bs0) next fix B a b assume "set gs ∪ set bs0 ⊆ B" hence B_sup: "set gs ∪ set bs ⊆ B" by (simp only: set_bs0) assume B_sub: "fst ` B ⊆ dgrad_p_set d m" assume "(a, b) ∈⇩p D0" hence ab_in: "(a, b) ∈⇩p set bs × (set gs ∪ set bs)" and "(a, b) ∉⇩p set ps0" by (simp_all add: assms(3)) assume "fst a ≠ 0" and "fst b ≠ 0" assume *: "⋀x y. x ∈ set gs ∪ set bs0 ⟹ y ∈ set gs ∪ set bs0 ⟹ (x, y) ∉⇩p D0 ⟹ fst x ≠ 0 ⟹ fst y ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst x) (fst y)" show "crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)" proof (cases "a = b") case True from ab_in have "b ∈ set gs ∪ set bs" unfolding True in_pair_iff set_diff_list by auto hence "fst b ∈ fst ` (set gs ∪ set bs)" by fastforce from this gs_bs_sub have "fst b ∈ dgrad_p_set d m" .. with dg show ?thesis unfolding True by (rule crit_pair_cbelow_same) next case False note ap dg moreover from B_sup have B_sup': "set gs ∪ set [] ∪ set bs ⊆ B" by simp moreover note B_sub moreover from ab_in have "(a, b) ∈⇩p set bs × (set gs ∪ set [] ∪ set bs)" by simp moreover have "set [] ⊆ set [] × (set gs ∪ set [])" by simp moreover from assms(7) have "unique_idx (gs @ [] @ bs) data" by (simp add: unique_idx_def set_bs0) ultimately show ?thesis using assms(6) False ‹fst a ≠ 0› ‹fst b ≠ 0› proof (rule ap_specD2) fix x y :: "('t, 'b, 'c) pdata" assume "(x, y) ∈⇩p set (ap gs [] [] bs data)" hence "(x, y) ∈⇩p set ps0" by (simp only: ps0_def) also have "... ⊆ set bs0 × (set gs ∪ set bs0)" by (fact ps0_sub) also have "... ⊆ (set gs ∪ set bs0) × (set gs ∪ set bs0)" by fastforce finally have "(x, y) ∈ (set gs ∪ set bs0) × (set gs ∪ set bs0)" by (simp only: in_pair_same) hence "x ∈ set gs ∪ set bs0" and "y ∈ set gs ∪ set bs0" by simp_all moreover from ‹(x, y) ∈⇩p set ps0› have "(x, y) ∉⇩p D0" by (simp add: D0_def) moreover assume "fst x ≠ 0" and "fst y ≠ 0" ultimately show "crit_pair_cbelow_on d m (fst ` B) (fst x) (fst y)" by (rule *) next fix x y :: "('t, 'b, 'c) pdata" assume "x ∈ set gs ∪ set []" and "y ∈ set gs ∪ set []" hence "fst x ∈ fst ` set gs" and "fst y ∈ fst ` set gs" by simp_all assume "fst x ≠ 0" and "fst y ≠ 0" with dg ‹fst ` set gs ⊆ dgrad_p_set d m› assms(6) ‹fst x ∈ fst ` set gs› ‹fst y ∈ fst ` set gs› have "crit_pair_cbelow_on d m (fst ` set gs) (fst x) (fst y)" by (rule GB_imp_crit_pair_cbelow_dgrad_p_set) moreover from B_sup have "fst ` set gs ⊆ fst ` B" by fastforce ultimately show "crit_pair_cbelow_on d m (fst ` B) (fst x) (fst y)" by (rule crit_pair_cbelow_mono) qed qed qed qed qed subsubsection ‹Function ‹gb_schema_aux›› function (domintros) gb_schema_aux :: "nat × nat × 'd ⇒ ('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata_pair list ⇒ ('t, 'b, 'c) pdata list" where "gb_schema_aux data bs ps = (if ps = [] then gs @ bs else (let sps = sel gs bs ps (snd data); ps0 = ps -- sps; aux = compl gs bs ps0 sps (snd data); remcomps = fst (data) - count_const_lt_components (fst aux) in (if remcomps = 0 then full_gb (gs @ bs) else let (hs, data') = add_indices aux (snd data) in gb_schema_aux (remcomps, data') (ab gs bs hs data') (ap gs bs ps0 hs data') ) ) )" by pat_completeness auto text ‹The ‹data› parameter of @{const gb_schema_aux} is a triple ‹(c, i, d)›, where ‹c› is the number of components ‹cmp› of the input list for which the current basis ‹gs @ bs› does @{emph ‹not›} yet contain an element whose leading power-product is ‹0› and has component ‹cmp›. As soon as ‹c› gets ‹0›, the function can return a trivial Gr\"obner basis, since then the submodule generated by the input list is just the full module. This idea generalizes the well-known fact that if a set of scalar polynomials contains a non-zero constant, the ideal generated by that set is the whole ring. ‹i› is the total number of polynomials generated during the execution of the function so far; it is used to attach unique indices to the polynomials for fast equality tests. ‹d›, finally, is some arbitrary data-field that may be used by concrete instances of @{const gb_schema_aux} for storing information.› lemma gb_schema_aux_domI1: "gb_schema_aux_dom (data, bs, [])" by (rule gb_schema_aux.domintros, simp) lemma gb_schema_aux_domI2: assumes "struct_spec sel ap ab compl" shows "gb_schema_aux_dom (data, args)" proof - from assms have sel: "sel_spec sel" and ap: "ap_spec ap" and ab: "ab_spec ab" by (rule struct_specD)+ from ex_dgrad obtain d::"'a ⇒ nat" where dg: "dickson_grading d" .. let ?R = "gb_schema_aux_term d gs" from dg have "wf ?R" by (rule gb_schema_aux_term_wf) thus ?thesis proof (induct args arbitrary: data rule: wf_induct_rule) fix x data assume IH: "⋀y data'. (y, x) ∈ ?R ⟹ gb_schema_aux_dom (data', y)" obtain bs ps where x: "x = (bs, ps)" by (meson case_prodE case_prodI2) show "gb_schema_aux_dom (data, x)" unfolding x proof (rule gb_schema_aux.domintros) fix rc0 n0 data0 hs n1 data1 assume "ps ≠ []" and hs_data': "(hs, n1, data1) = add_indices (compl gs bs (ps -- sel gs bs ps (n0, data0)) (sel gs bs ps (n0, data0)) (n0, data0)) (n0, data0)" and data: "data = (rc0, n0, data0)" define sps where "sps = sel gs bs ps (n0, data0)" define data' where "data' = (n1, data1)" define rc where "rc = rc0 - count_const_lt_components (fst (compl gs bs (ps -- sel gs bs ps (n0, data0)) (sel gs bs ps (n0, data0)) (n0, data0)))" from hs_data' have hs: "hs = fst (add_indices (compl gs bs (ps -- sps) sps (snd data)) (snd data))" unfolding sps_def data snd_conv by (metis fstI) show "gb_schema_aux_dom ((rc, data'), ab gs bs hs data', ap gs bs (ps -- sps) hs data')" proof (rule IH, simp add: x gb_schema_aux_term_def gb_schema_aux_term1_def gb_schema_aux_term2_def, intro conjI) show "fst ` set (ab gs bs hs data') ⊐p fst ` set bs ∨ ab gs bs hs data' = bs ∧ card (set (ap gs bs (ps -- sps) hs data')) < card (set ps)" proof (cases "hs = []") case True have "ab gs bs hs data' = bs ∧ card (set (ap gs bs (ps -- sps) hs data')) < card (set ps)" proof (simp only: True, rule) from ab show "ab gs bs [] data' = bs" by (rule ab_specD2) next from sel ‹ps ≠ []› have "sps ≠ []" and "set sps ⊆ set ps" unfolding sps_def by (rule sel_specD1, rule sel_specD2) moreover from sel_specD1[OF sel ‹ps ≠ []›] have "set sps ≠ {}" by (simp add: sps_def) ultimately have "set ps ∩ set sps ≠ {}" by (simp add: inf.absorb_iff2) hence "set (ps -- sps) ⊂ set ps" unfolding set_diff_list by fastforce hence "card (set (ps -- sps)) < card (set ps)" by (simp add: psubset_card_mono) moreover have "card (set (ap gs bs (ps -- sps) [] data')) ≤ card (set (ps -- sps))" by (rule card_mono, fact finite_set, rule ap_spec_Nil_subset, fact ap) ultimately show "card (set (ap gs bs (ps -- sps) [] data')) < card (set ps)" by simp qed thus ?thesis .. next case False with assms ‹ps ≠ []› sps_def hs have "fst ` set (ab gs bs hs data') ⊐p fst ` set bs" unfolding data snd_conv by (rule struct_spec_red_supset) thus ?thesis .. qed next from dg assms ‹ps ≠ []› sps_def hs show "dgrad_p_set_le d (args_to_set (gs, ab gs bs hs data', ap gs bs (ps -- sps) hs data')) (args_to_set (gs, bs, ps))" unfolding data snd_conv by (rule dgrad_p_set_le_args_to_set_struct) next from assms ‹ps ≠ []› sps_def hs show "component_of_term ` Keys (args_to_set (gs, ab gs bs hs data', ap gs bs (ps -- sps) hs data')) ⊆ component_of_term ` Keys (args_to_set (gs, bs, ps))" unfolding data snd_conv by (rule components_subset_struct) qed qed qed qed lemma gb_schema_aux_Nil [simp, code]: "gb_schema_aux data bs [] = gs @ bs" by (simp add: gb_schema_aux.psimps[OF gb_schema_aux_domI1]) lemmas gb_schema_aux_simps = gb_schema_aux.psimps[OF gb_schema_aux_domI2] lemma gb_schema_aux_induct [consumes 1, case_names base rec1 rec2]: assumes "struct_spec sel ap ab compl" assumes base: "⋀bs data. P data bs [] (gs @ bs)" and rec1: "⋀bs ps sps data. ps ≠ [] ⟹ sps = sel gs bs ps (snd data) ⟹ fst (data) ≤ count_const_lt_components (fst (compl gs bs (ps -- sps) sps (snd data))) ⟹ P data bs ps (full_gb (gs @ bs))" and rec2: "⋀bs ps sps aux hs rc data data'. ps ≠ [] ⟹ sps = sel gs bs ps (snd data) ⟹ aux = compl gs bs (ps -- sps) sps (snd data) ⟹ (hs, data') = add_indices aux (snd data) ⟹ rc = fst data - count_const_lt_components (fst aux) ⟹ 0 < rc ⟹ P (rc, data') (ab gs bs hs data') (ap gs bs (ps -- sps) hs data') (gb_schema_aux (rc, data') (ab gs bs hs data') (ap gs bs (ps -- sps) hs data')) ⟹ P data bs ps (gb_schema_aux (rc, data') (ab gs bs hs data') (ap gs bs (ps -- sps) hs data'))" shows "P data bs ps (gb_schema_aux data bs ps)" proof - from assms(1) have "gb_schema_aux_dom (data, bs, ps)" by (rule gb_schema_aux_domI2) thus ?thesis proof (induct data bs ps rule: gb_schema_aux.pinduct) case (1 data bs ps) show ?case proof (cases "ps = []") case True show ?thesis by (simp add: True, rule base) next case False show ?thesis proof (simp add: gb_schema_aux_simps[OF assms(1), of data bs ps] False Let_def split: if_split, intro conjI impI) define sps where "sps = sel gs bs ps (snd data)" assume "fst data ≤ count_const_lt_components (fst (compl gs bs (ps -- sps) sps (snd data)))" with False sps_def show "P data bs ps (full_gb (gs @ bs))" by (rule rec1) next define sps where "sps = sel gs bs ps (snd data)" define aux where "aux = compl gs bs (ps -- sps) sps (snd data)" define hs where "hs = fst (add_indices aux (snd data))" define data' where "data' = snd (add_indices aux (snd data))" define rc where "rc = fst data - count_const_lt_components (fst aux)" have eq: "add_indices aux (snd data) = (hs, data')" by (simp add: hs_def data'_def) assume "¬ fst data ≤ count_const_lt_components (fst aux)" hence "0 < rc" by (simp add: rc_def) hence "rc ≠ 0" by simp show "P data bs ps (case add_indices aux (snd data) of (hs, data') ⇒ gb_schema_aux (rc, data') (ab gs bs hs data') (ap gs bs (ps -- sps) hs data'))" unfolding eq prod.case using False sps_def aux_def eq[symmetric] rc_def ‹0 < rc› proof (rule rec2) show "P (rc, data') (ab gs bs hs data') (ap gs bs (ps -- sps) hs data') (gb_schema_aux (rc, data') (ab gs bs hs data') (ap gs bs (ps -- sps) hs data'))" using False sps_def refl aux_def rc_def ‹rc ≠ 0› eq[symmetric] refl by (rule 1) qed qed qed qed qed lemma gb_schema_dummy_eq_gb_schema_aux: assumes "struct_spec sel ap ab compl" shows "fst (gb_schema_dummy data D bs ps) = gb_schema_aux data bs ps" using assms proof (induct data D bs ps rule: gb_schema_dummy_induct) case (base bs data D) show ?case by simp next case (rec1 bs ps sps data D) thus ?case by (simp add: gb_schema_aux.psimps[OF gb_schema_aux_domI2, OF assms]) next case (rec2 bs ps sps aux hs rc data data' D D') note rec2.hyps(8) also from rec2.hyps(1, 2, 3) rec2.hyps(4)[symmetric] rec2.hyps(5, 6, 7) have "gb_schema_aux (rc, data') (ab gs bs hs data') (ap gs bs (ps -- sps) hs data') = gb_schema_aux data bs ps" by (simp add: gb_schema_aux.psimps[OF gb_schema_aux_domI2, OF assms, of data] Let_def) finally show ?case . qed corollary gb_schema_aux_dgrad_p_set_le: assumes "dickson_grading d" and "struct_spec sel ap ab compl" shows "dgrad_p_set_le d (fst ` set (gb_schema_aux data bs ps)) (args_to_set (gs, bs, ps))" using fst_gb_schema_dummy_dgrad_p_set_le[OF assms] unfolding gb_schema_dummy_eq_gb_schema_aux[OF assms(2)] . corollary gb_schema_aux_components: assumes "struct_spec sel ap ab compl" and "set ps ⊆ set bs × (set gs ∪ set bs)" shows "component_of_term ` Keys (fst ` set (gb_schema_aux data bs ps)) = component_of_term ` Keys (args_to_set (gs, bs, ps))" using fst_gb_schema_dummy_components[OF assms] unfolding gb_schema_dummy_eq_gb_schema_aux[OF assms(1)] . lemma gb_schema_aux_pmdl: assumes "struct_spec sel ap ab compl" and "compl_pmdl compl" and "is_Groebner_basis (fst ` set gs)" and "set ps ⊆ set bs × (set gs ∪ set bs)" and "unique_idx (gs @ bs) (snd data)" and "rem_comps_spec (gs @ bs) data" shows "pmdl (fst ` set (gb_schema_aux data bs ps)) = pmdl (fst ` set (gs @ bs))" using fst_gb_schema_dummy_pmdl[OF assms] unfolding gb_schema_dummy_eq_gb_schema_aux[OF assms(1)] . corollary gb_schema_aux_dgrad_p_set_le_init: assumes "dickson_grading d" and "struct_spec sel ap ab compl" shows "dgrad_p_set_le d (fst ` set (gb_schema_aux data (ab gs [] bs (snd data)) (ap gs [] [] bs (snd data)))) (fst ` (set gs ∪ set bs))" using fst_gb_schema_dummy_dgrad_p_set_le_init[OF assms] unfolding gb_schema_dummy_eq_gb_schema_aux[OF assms(2)] . corollary gb_schema_aux_dgrad_p_set_init: assumes "dickson_grading d" and "struct_spec sel ap ab compl" and "fst ` (set gs ∪ set bs) ⊆ dgrad_p_set d m" shows "fst ` set (gb_schema_aux (rc, data) (ab gs [] bs data) (ap gs [] [] bs data)) ⊆ dgrad_p_set d m" using fst_gb_schema_dummy_dgrad_p_set_init[OF assms] unfolding gb_schema_dummy_eq_gb_schema_aux[OF assms(2)] . corollary gb_schema_aux_components_init: assumes "struct_spec sel ap ab compl" shows "component_of_term ` Keys (fst ` set (gb_schema_aux (rc, data) (ab gs [] bs data) (ap gs [] [] bs data))) = component_of_term ` Keys (fst ` set (gs @ bs))" using fst_gb_schema_dummy_components_init[OF assms] unfolding gb_schema_dummy_eq_gb_schema_aux[OF assms] . corollary gb_schema_aux_pmdl_init: assumes "struct_spec sel ap ab compl" and "compl_pmdl compl" and "is_Groebner_basis (fst ` set gs)" and "unique_idx (gs @ ab gs [] bs data) data" and "rem_comps_spec (gs @ ab gs [] bs data) (rc, data)" shows "pmdl (fst ` set (gb_schema_aux (rc, data) (ab gs [] bs data) (ap gs [] [] bs data))) = pmdl (fst ` (set (gs @ bs)))" using fst_gb_schema_dummy_pmdl_init[OF assms] unfolding gb_schema_dummy_eq_gb_schema_aux[OF assms(1)] . lemma gb_schema_aux_isGB_init: assumes "struct_spec sel ap ab compl" and "compl_conn compl" and "is_Groebner_basis (fst ` set gs)" and "unique_idx (gs @ ab gs [] bs data) data" and "rem_comps_spec (gs @ ab gs [] bs data) (rc, data)" shows "is_Groebner_basis (fst ` set (gb_schema_aux (rc, data) (ab gs [] bs data) (ap gs [] [] bs data)))" using fst_gb_schema_dummy_isGB_init[OF assms] unfolding gb_schema_dummy_eq_gb_schema_aux[OF assms(1)] . end subsubsection ‹Functions ‹gb_schema_direct› and ‹term gb_schema_incr›› definition gb_schema_direct :: "('t, 'b, 'c, 'd) selT ⇒ ('t, 'b, 'c, 'd) apT ⇒ ('t, 'b, 'c, 'd) abT ⇒ ('t, 'b, 'c, 'd) complT ⇒ ('t, 'b, 'c) pdata' list ⇒ 'd ⇒ ('t, 'b::field, 'c::default) pdata' list" where "gb_schema_direct sel ap ab compl bs0 data0 = (let data = (length bs0, data0); bs1 = fst (add_indices (bs0, data0) (0, data0)); bs = ab [] [] bs1 data in map (λ(f, _, d). (f, d)) (gb_schema_aux sel ap ab compl [] (count_rem_components bs, data) bs (ap [] [] [] bs1 data)) )" primrec gb_schema_incr :: "('t, 'b, 'c, 'd) selT ⇒ ('t, 'b, 'c, 'd) apT ⇒ ('t, 'b, 'c, 'd) abT ⇒ ('t, 'b, 'c, 'd) complT ⇒ (('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata ⇒ 'd ⇒ 'd) ⇒ ('t, 'b, 'c) pdata' list ⇒ 'd ⇒ ('t, 'b::field, 'c::default) pdata' list" where "gb_schema_incr _ _ _ _ _ [] _ = []"| "gb_schema_incr sel ap ab compl upd (b0 # bs) data = (let (gs, n, data') = add_indices (gb_schema_incr sel ap ab compl upd bs data, data) (0, data); b = (fst b0, n, snd b0); data'' = upd gs b data' in map (λ(f, _, d). (f, d)) (gb_schema_aux sel ap ab compl gs (count_rem_components (b # gs), Suc n, data'') (ab gs [] [b] (Suc n, data'')) (ap gs [] [] [b] (Suc n, data''))) )" lemma (in -) fst_set_drop_indices: "fst ` (λ(f, _, d). (f, d)) ` A = fst ` A" for A::"('x × 'y × 'z) set" by (simp add: image_image, rule image_cong, fact refl, simp add: prod.case_eq_if) lemma fst_gb_schema_direct: "fst ` set (gb_schema_direct sel ap ab compl bs0 data0) = (let data = (length bs0, data0); bs1 = fst (add_indices (bs0, data0) (0, data0)); bs = ab [] [] bs1 data in fst ` set (gb_schema_aux sel ap ab compl [] (count_rem_components bs, data) bs (ap [] [] [] bs1 data)) )" by (simp add: gb_schema_direct_def Let_def fst_set_drop_indices) lemma gb_schema_direct_dgrad_p_set: assumes "dickson_grading d" and "struct_spec sel ap ab compl" and "fst ` set bs ⊆ dgrad_p_set d m" shows "fst ` set (gb_schema_direct sel ap ab compl bs data) ⊆ dgrad_p_set d m" unfolding fst_gb_schema_direct Let_def using assms(1, 2) proof (rule gb_schema_aux_dgrad_p_set_init) show "fst ` (set [] ∪ set (fst (add_indices (bs, data) (0, data)))) ⊆ dgrad_p_set d m" using assms(3) by (simp add: image_Un fst_set_add_indices) qed theorem gb_schema_direct_isGB: assumes "struct_spec sel ap ab compl" and "compl_conn compl" shows "is_Groebner_basis (fst ` set (gb_schema_direct sel ap ab compl bs data))" unfolding fst_gb_schema_direct Let_def using assms proof (rule gb_schema_aux_isGB_init) from is_Groebner_basis_empty show "is_Groebner_basis (fst ` set [])" by simp next let ?data = "(length bs, data)" from assms(1) have "ab_spec ab" by (rule struct_specD) moreover have "unique_idx ([] @ []) (0, data)" by (simp add: unique_idx_Nil) ultimately show "unique_idx ([] @ ab [] [] (fst (add_indices (bs, data) (0, data))) ?data) ?data" proof (rule unique_idx_ab) show "(fst (add_indices (bs, data) (0, data)), length bs, data) = add_indices (bs, data) (0, data)" by (simp add: add_indices_def) qed qed (simp add: rem_comps_spec_count_rem_components) theorem gb_schema_direct_pmdl: assumes "struct_spec sel ap ab compl" and "compl_pmdl compl" shows "pmdl (fst ` set (gb_schema_direct sel ap ab compl bs data)) = pmdl (fst ` set bs)" proof - have "pmdl (fst ` set (gb_schema_direct sel ap ab compl bs data)) = pmdl (fst ` set ([] @ (fst (add_indices (bs, data) (0, data)))))" unfolding fst_gb_schema_direct Let_def using assms proof (rule gb_schema_aux_pmdl_init) from is_Groebner_basis_empty show "is_Groebner_basis (fst ` set [])" by simp next let ?data = "(length bs, data)" from assms(1) have "ab_spec ab" by (rule struct_specD) moreover have "unique_idx ([] @ []) (0, data)" by (simp add: unique_idx_Nil) ultimately show "unique_idx ([] @ ab [] [] (fst (add_indices (bs, data) (0, data))) ?data) ?data" proof (rule unique_idx_ab) show "(fst (add_indices (bs, data) (0, data)), length bs, data) = add_indices (bs, data) (0, data)" by (simp add: add_indices_def) qed qed (simp add: rem_comps_spec_count_rem_components) thus ?thesis by (simp add: fst_set_add_indices) qed lemma fst_gb_schema_incr: "fst ` set (gb_schema_incr sel ap ab compl upd (b0 # bs) data) = (let (gs, n, data') = add_indices (gb_schema_incr sel ap ab compl upd bs data, data) (0, data); b = (fst b0, n, snd b0); data'' = upd gs b data' in fst ` set (gb_schema_aux sel ap ab compl gs (count_rem_components (b # gs), Suc n, data'') (ab gs [] [b] (Suc n, data'')) (ap gs [] [] [b] (Suc n, data''))) )" by (simp only: gb_schema_incr.simps Let_def prod.case_distrib[of set] prod.case_distrib[of "image fst"] set_map fst_set_drop_indices) lemma gb_schema_incr_dgrad_p_set: assumes "dickson_grading d" and "struct_spec sel ap ab compl" and "fst ` set bs ⊆ dgrad_p_set d m" shows "fst ` set (gb_schema_incr sel ap ab compl upd bs data) ⊆ dgrad_p_set d m" using assms(3) proof (induct bs) case Nil show ?case by simp next case (Cons b0 bs) from Cons(2) have 1: "fst b0 ∈ dgrad_p_set d m" and 2: "fst ` set bs ⊆ dgrad_p_set d m" by simp_all show ?case proof (simp only: fst_gb_schema_incr Let_def split: prod.splits, simp, intro allI impI) fix gs n data' assume "add_indices (gb_schema_incr sel ap ab compl upd bs data, data) (0, data) = (gs, n, data')" hence gs: "gs = fst (add_indices (gb_schema_incr sel ap ab compl upd bs data, data) (0, data))" by simp define b where "b = (fst b0, n, snd b0)" define data'' where "data'' = upd gs b data'" from assms(1, 2) show "fst ` set (gb_schema_aux sel ap ab compl gs (count_rem_components (b # gs), Suc n, data'') (ab gs [] [b] (Suc n, data'')) (ap gs [] [] [b] (Suc n, data''))) ⊆ dgrad_p_set d m" proof (rule gb_schema_aux_dgrad_p_set_init) from 1 Cons(1)[OF 2] show "fst ` (set gs ∪ set [b]) ⊆ dgrad_p_set d m" by (simp add: gs fst_set_add_indices b_def) qed qed qed theorem gb_schema_incr_dgrad_p_set_isGB: assumes "struct_spec sel ap ab compl" and "compl_conn compl" shows "is_Groebner_basis (fst ` set (gb_schema_incr sel ap ab compl upd bs data))" proof (induct bs) case Nil from is_Groebner_basis_empty show ?case by simp next case (Cons b0 bs) show ?case proof (simp only: fst_gb_schema_incr Let_def split: prod.splits, simp, intro allI impI) fix gs n data' assume *: "add_indices (gb_schema_incr sel ap ab compl upd bs data, data) (0, data) = (gs, n, data')" hence gs: "gs = fst (add_indices (gb_schema_incr sel ap ab compl upd bs data, data) (0, data))" by simp define b where "b = (fst b0, n, snd b0)" define data'' where "data'' = upd gs b data'" from assms(1) have ab: "ab_spec ab" by (rule struct_specD3) from Cons have "is_Groebner_basis (fst ` set gs)" by (simp add: gs fst_set_add_indices) with assms show "is_Groebner_basis (fst ` set (gb_schema_aux sel ap ab compl gs (count_rem_components (b # gs), Suc n, data'') (ab gs [] [b] (Suc n, data'')) (ap gs [] [] [b] (Suc n, data''))))" proof (rule gb_schema_aux_isGB_init) from ab show "unique_idx (gs @ ab gs [] [b] (Suc n, data'')) (Suc n, data'')" proof (rule unique_idx_ab) from unique_idx_Nil *[symmetric] have "unique_idx ([] @ gs) (n, data')" by (rule unique_idx_append) thus "unique_idx (gs @ []) (n, data')" by simp next show "([b], Suc n, data'') = add_indices ([b0], data'') (n, data')" by (simp add: add_indices_def b_def) qed next have "rem_comps_spec (b # gs) (count_rem_components (b # gs), Suc n, data'')" by (fact rem_comps_spec_count_rem_components) moreover have "set (b # gs) = set (gs @ ab gs [] [b] (Suc n, data''))" by (simp add: ab_specD1[OF ab]) ultimately show "rem_comps_spec (gs @ ab gs [] [b] (Suc n, data'')) (count_rem_components (b # gs), Suc n, data'')" by (simp only: rem_comps_spec_def) qed qed qed theorem gb_schema_incr_pmdl: assumes "struct_spec sel ap ab compl" and "compl_conn compl" "compl_pmdl compl" shows "pmdl (fst ` set (gb_schema_incr sel ap ab compl upd bs data)) = pmdl (fst ` set bs)" proof (induct bs) case Nil show ?case by simp next case (Cons b0 bs) show ?case proof (simp only: fst_gb_schema_incr Let_def split: prod.splits, simp, intro allI impI) fix gs n data' assume *: "add_indices (gb_schema_incr sel ap ab compl upd bs data, data) (0, data) = (gs, n, data')" hence gs: "gs = fst (add_indices (gb_schema_incr sel ap ab compl upd bs data, data) (0, data))" by simp define b where "b = (fst b0, n, snd b0)" define data'' where "data'' = upd gs b data'" from assms(1) have ab: "ab_spec ab" by (rule struct_specD3) from assms(1, 2) have "is_Groebner_basis (fst ` set gs)" unfolding gs fst_conv fst_set_add_indices by (rule gb_schema_incr_dgrad_p_set_isGB) with assms(1, 3) have eq: "pmdl (fst ` set (gb_schema_aux sel ap ab compl gs (count_rem_components (b # gs), Suc n, data'') (ab gs [] [b] (Suc n, data'')) (ap gs [] [] [b] (Suc n, data'')))) = pmdl (fst ` set (gs @ [b]))" proof (rule gb_schema_aux_pmdl_init) from ab show "unique_idx (gs @ ab gs [] [b] (Suc n, data'')) (Suc n, data'')" proof (rule unique_idx_ab) from unique_idx_Nil *[symmetric] have "unique_idx ([] @ gs) (n, data')" by (rule unique_idx_append) thus "unique_idx (gs @ []) (n, data')" by simp next show "([b], Suc n, data'') = add_indices ([b0], data'') (n, data')" by (simp add: add_indices_def b_def) qed next have "rem_comps_spec (b # gs) (count_rem_components (b # gs), Suc n, data'')" by (fact rem_comps_spec_count_rem_components) moreover have "set (b # gs) = set (gs @ ab gs [] [b] (Suc n, data''))" by (simp add: ab_specD1[OF ab]) ultimately show "rem_comps_spec (gs @ ab gs [] [b] (Suc n, data'')) (count_rem_components (b # gs), Suc n, data'')" by (simp only: rem_comps_spec_def) qed also have "... = pmdl (insert (fst b) (fst ` set gs))" by simp also from Cons have "... = pmdl (insert (fst b) (fst ` set bs))" unfolding gs fst_conv fst_set_add_indices by (rule pmdl.span_insert_cong) finally show "pmdl (fst ` set (gb_schema_aux sel ap ab compl gs (count_rem_components (b # gs), Suc n, data'') (ab gs [] [b] (Suc n, data'')) (ap gs [] [] [b] (Suc n, data'')))) = pmdl (insert (fst b0) (fst ` set bs))" by (simp add: b_def) qed qed subsection ‹Suitable Instances of the @{emph ‹add-pairs›} Parameter› subsubsection ‹Specification of the @{emph ‹crit›} parameters› type_synonym (in -) ('t, 'b, 'c, 'd) icritT = "nat × 'd ⇒ ('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata ⇒ ('t, 'b, 'c) pdata ⇒ bool" type_synonym (in -) ('t, 'b, 'c, 'd) ncritT = "nat × 'd ⇒ ('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata list ⇒ bool ⇒ (bool × ('t, 'b, 'c) pdata_pair) list ⇒ ('t, 'b, 'c) pdata ⇒ ('t, 'b, 'c) pdata ⇒ bool" type_synonym (in -) ('t, 'b, 'c, 'd) ocritT = "nat × 'd ⇒ ('t, 'b, 'c) pdata list ⇒ (bool × ('t, 'b, 'c) pdata_pair) list ⇒ ('t, 'b, 'c) pdata ⇒ ('t, 'b, 'c) pdata ⇒ bool" definition icrit_spec :: "('t, 'b::field, 'c, 'd) icritT ⇒ bool" where "icrit_spec crit ⟷ (∀d m data gs bs hs p q. dickson_grading d ⟶ fst ` (set gs ∪ set bs ∪ set hs) ⊆ dgrad_p_set d m ⟶ unique_idx (gs @ bs @ hs) data ⟶ is_Groebner_basis (fst ` set gs) ⟶ p ∈ set hs ⟶ q ∈ set gs ∪ set bs ∪ set hs ⟶ fst p ≠ 0 ⟶ fst q ≠ 0 ⟶ crit data gs bs hs p q ⟶ crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs ∪ set hs)) (fst p) (fst q))" text ‹Criteria satisfying @{const icrit_spec} can be used for discarding pairs @{emph ‹instantly›}, without reference to any other pairs. The product criterion for scalar polynomials satisfies @{const icrit_spec}, and so does the component criterion (which checks whether the component-indices of the leading terms of two polynomials are identical).› definition ncrit_spec :: "('t, 'b::field, 'c, 'd) ncritT ⇒ bool" where "ncrit_spec crit ⟷ (∀d m data gs bs hs ps B q_in_bs p q. dickson_grading d ⟶ set gs ∪ set bs ∪ set hs ⊆ B ⟶ fst ` B ⊆ dgrad_p_set d m ⟶ snd ` set ps ⊆ set hs × (set gs ∪ set bs ∪ set hs) ⟶ unique_idx (gs @ bs @ hs) data ⟶ is_Groebner_basis (fst ` set gs) ⟶ (q_in_bs ⟶ (q ∈ set gs ∪ set bs)) ⟶ (∀p' q'. (p', q') ∈⇩p snd ` set ps ⟶ fst p' ≠ 0 ⟶ fst q' ≠ 0 ⟶ crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')) ⟶ (∀p' q'. p' ∈ set gs ∪ set bs ⟶ q' ∈ set gs ∪ set bs ⟶ fst p' ≠ 0 ⟶ fst q' ≠ 0 ⟶ crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')) ⟶ p ∈ set hs ⟶ q ∈ set gs ∪ set bs ∪ set hs ⟶ fst p ≠ 0 ⟶ fst q ≠ 0 ⟶ crit data gs bs hs q_in_bs ps p q ⟶ crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q))" definition ocrit_spec :: "('t, 'b::field, 'c, 'd) ocritT ⇒ bool" where "ocrit_spec crit ⟷ (∀d m data hs ps B p q. dickson_grading d ⟶ set hs ⊆ B ⟶ fst ` B ⊆ dgrad_p_set d m ⟶ unique_idx (p # q # hs @ (map (fst ∘ snd) ps) @ (map (snd ∘ snd) ps)) data ⟶ (∀p' q'. (p', q') ∈⇩p snd ` set ps ⟶ fst p' ≠ 0 ⟶ fst q' ≠ 0 ⟶ crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')) ⟶ p ∈ B ⟶ q ∈ B ⟶ fst p ≠ 0 ⟶ fst q ≠ 0 ⟶ crit data hs ps p q ⟶ crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q))" text ‹Criteria satisfying @{const ncrit_spec} can be used for discarding new pairs by reference to new and old elements, whereas criteria satisfying @{const ocrit_spec} can be used for discarding old pairs by reference to new elements @{emph ‹only›} (no existing ones!). The chain criterion satisfies both @{const ncrit_spec} and @{const ocrit_spec}.› lemma icrit_specI: assumes "⋀d m data gs bs hs p q. dickson_grading d ⟹ fst ` (set gs ∪ set bs ∪ set hs) ⊆ dgrad_p_set d m ⟹ unique_idx (gs @ bs @ hs) data ⟹ is_Groebner_basis (fst ` set gs) ⟹ p ∈ set hs ⟹ q ∈ set gs ∪ set bs ∪ set hs ⟹ fst p ≠ 0 ⟹ fst q ≠ 0 ⟹ crit data gs bs hs p q ⟹ crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs ∪ set hs)) (fst p) (fst q)" shows "icrit_spec crit" unfolding icrit_spec_def using assms by auto lemma icrit_specD: assumes "icrit_spec crit" and "dickson_grading d" and "fst ` (set gs ∪ set bs ∪ set hs) ⊆ dgrad_p_set d m" and "unique_idx (gs @ bs @ hs) data" and "is_Groebner_basis (fst ` set gs)" and "p ∈ set hs" and "q ∈ set gs ∪ set bs ∪ set hs" and "fst p ≠ 0" and "fst q ≠ 0" and "crit data gs bs hs p q" shows "crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs ∪ set hs)) (fst p) (fst q)" using assms unfolding icrit_spec_def by blast lemma ncrit_specI: assumes "⋀d m data gs bs hs ps B q_in_bs p q. dickson_grading d ⟹ set gs ∪ set bs ∪ set hs ⊆ B ⟹ fst ` B ⊆ dgrad_p_set d m ⟹ snd ` set ps ⊆ set hs × (set gs ∪ set bs ∪ set hs) ⟹ unique_idx (gs @ bs @ hs) data ⟹ is_Groebner_basis (fst ` set gs) ⟹ (q_in_bs ⟶ q ∈ set gs ∪ set bs) ⟹ (⋀p' q'. (p', q') ∈⇩p snd ` set ps ⟹ fst p' ≠ 0 ⟹ fst q' ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')) ⟹ (⋀p' q'. p' ∈ set gs ∪ set bs ⟹ q' ∈ set gs ∪ set bs ⟹ fst p' ≠ 0 ⟹ fst q' ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')) ⟹ p ∈ set hs ⟹ q ∈ set gs ∪ set bs ∪ set hs ⟹ fst p ≠ 0 ⟹ fst q ≠ 0 ⟹ crit data gs bs hs q_in_bs ps p q ⟹ crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q)" shows "ncrit_spec crit" unfolding ncrit_spec_def by (intro allI impI, rule assms, assumption+, meson, meson, assumption+) lemma ncrit_specD: assumes "ncrit_spec crit" and "dickson_grading d" and "set gs ∪ set bs ∪ set hs ⊆ B" and "fst ` B ⊆ dgrad_p_set d m" and "snd ` set ps ⊆ set hs × (set gs ∪ set bs ∪ set hs)" and "unique_idx (gs @ bs @ hs) data" and "is_Groebner_basis (fst ` set gs)" and "q_in_bs ⟹ q ∈ set gs ∪ set bs" and "⋀p' q'. (p', q') ∈⇩p snd ` set ps ⟹ fst p' ≠ 0 ⟹ fst q' ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')" and "⋀p' q'. p' ∈ set gs ∪ set bs ⟹ q' ∈ set gs ∪ set bs ⟹ fst p' ≠ 0 ⟹ fst q' ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')" and "p ∈ set hs" and "q ∈ set gs ∪ set bs ∪ set hs" and "fst p ≠ 0" and "fst q ≠ 0" and "crit data gs bs hs q_in_bs ps p q" shows "crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q)" using assms unfolding ncrit_spec_def by blast lemma ocrit_specI: assumes "⋀d m data hs ps B p q. dickson_grading d ⟹ set hs ⊆ B ⟹ fst ` B ⊆ dgrad_p_set d m ⟹ unique_idx (p # q # hs @ (map (fst ∘ snd) ps) @ (map (snd ∘ snd) ps)) data ⟹ (⋀p' q'. (p', q') ∈⇩p snd ` set ps ⟹ fst p' ≠ 0 ⟹ fst q' ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')) ⟹ p ∈ B ⟹ q ∈ B ⟹ fst p ≠ 0 ⟹ fst q ≠ 0 ⟹ crit data hs ps p q ⟹ crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q)" shows "ocrit_spec crit" unfolding ocrit_spec_def by (intro allI impI, rule assms, assumption+, meson, assumption+) lemma ocrit_specD: assumes "ocrit_spec crit" and "dickson_grading d" and "set hs ⊆ B" and "fst ` B ⊆ dgrad_p_set d m" and "unique_idx (p # q # hs @ (map (fst ∘ snd) ps) @ (map (snd ∘ snd) ps)) data" and "⋀p' q'. (p', q') ∈⇩p snd ` set ps ⟹ fst p' ≠ 0 ⟹ fst q' ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')" and "p ∈ B" and "q ∈ B" and "fst p ≠ 0" and "fst q ≠ 0" and "crit data hs ps p q" shows "crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q)" using assms unfolding ocrit_spec_def by blast subsubsection ‹Suitable instances of the @{emph ‹crit›} parameters› definition component_crit :: "('t, 'b::zero, 'c, 'd) icritT" where "component_crit data gs bs hs p q ⟷ (component_of_term (lt (fst p)) ≠ component_of_term (lt (fst q)))" lemma icrit_spec_component_crit: "icrit_spec (component_crit::('t, 'b::field, 'c, 'd) icritT)" proof (rule icrit_specI) fix d m and data::"nat × 'd" and gs bs hs and p q::"('t, 'b, 'c) pdata" assume "component_crit data gs bs hs p q" hence "component_of_term (lt (fst p)) ≠ component_of_term (lt (fst q))" by (simp add: component_crit_def) thus "crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs ∪ set hs)) (fst p) (fst q)" by (rule crit_pair_cbelow_distinct_component) qed text ‹The product criterion is only applicable to scalar polynomials.› definition product_crit :: "('a, 'b::zero, 'c, 'd) icritT" where "product_crit data gs bs hs p q ⟷ (gcs (punit.lt (fst p)) (punit.lt (fst q)) = 0)" lemma (in gd_term) icrit_spec_product_crit: "punit.icrit_spec (product_crit::('a, 'b::field, 'c, 'd) icritT)" proof (rule punit.icrit_specI) fix d m and data::"nat × 'd" and gs bs hs and p q::"('a, 'b, 'c) pdata" assume "product_crit data gs bs hs p q" hence *: "gcs (punit.lt (fst p)) (punit.lt (fst q)) = 0" by (simp only: product_crit_def) assume "p ∈ set hs" and q_in: "q ∈ set gs ∪ set bs ∪ set hs" (is "_ ∈ ?B") assume "dickson_grading d" and sub: "fst ` (set gs ∪ set bs ∪ set hs) ⊆ punit.dgrad_p_set d m" moreover from ‹p ∈ set hs› have "fst p ∈ fst ` ?B" by simp moreover from q_in have "fst q ∈ fst ` ?B" by simp moreover assume "fst p ≠ 0" and "fst q ≠ 0" ultimately show "punit.crit_pair_cbelow_on d m (fst ` ?B) (fst p) (fst q)" using * by (rule product_criterion) qed text ‹@{const component_crit} and @{const product_crit} ignore the ‹data› parameter.› fun (in -) pair_in_list :: "(bool × ('a, 'b, 'c) pdata_pair) list ⇒ nat ⇒ nat ⇒ bool" where "pair_in_list [] _ _ = False" |"pair_in_list ((_, (_, i', _), (_, j', _)) # ps) i j = ((i = i' ∧ j = j') ∨ (i = j' ∧ j = i') ∨ pair_in_list ps i j)" lemma (in -) pair_in_listE: assumes "pair_in_list ps i j" obtains p q a b where "((p, i, a), (q, j, b)) ∈⇩p snd ` set ps" using assms proof (induct ps i j arbitrary: thesis rule: pair_in_list.induct) case (1 i j) from 1(2) show ?case by simp next case (2 c p i' a q j' b ps i j) from 2(3) have "(i = i' ∧ j = j') ∨ (i = j' ∧ j = i') ∨ pair_in_list ps i j" by simp thus ?case proof (elim disjE conjE) assume "i = i'" and "j = j'" have "((p, i, a), (q, j, b)) ∈⇩p snd ` set ((c, (p, i', a), q, j', b) # ps)" unfolding ‹i = i'› ‹j = j'› in_pair_iff by fastforce thus ?thesis by (rule 2(2)) next assume "i = j'" and "j = i'" have "((q, i, b), (p, j, a)) ∈⇩p snd ` set ((c, (p, i', a), q, j', b) # ps)" unfolding ‹i = j'› ‹j = i'› in_pair_iff by fastforce thus ?thesis by (rule 2(2)) next assume "pair_in_list ps i j" obtain p' q' a' b' where "((p', i, a'), (q', j, b')) ∈⇩p snd ` set ps" by (rule 2(1), assumption, rule ‹pair_in_list ps i j›) also have "... ⊆ snd ` set ((c, (p, i', a), q, j', b) # ps)" by auto finally show ?thesis by (rule 2(2)) qed qed definition chain_ncrit :: "('t, 'b::zero, 'c, 'd) ncritT" where "chain_ncrit data gs bs hs q_in_bs ps p q ⟷ (let v = lt (fst p); l = term_of_pair (lcs (pp_of_term v) (lp (fst q)), component_of_term v); i = fst (snd p); j = fst (snd q) in (∃r∈set gs. let k = fst (snd r) in k ≠ i ∧ k ≠ j ∧ lt (fst r) adds⇩t l ∧ pair_in_list ps i k ∧ (q_in_bs ∨ pair_in_list ps j k) ∧ fst r ≠ 0) ∨ (∃r∈set bs. let k = fst (snd r) in k ≠ i ∧ k ≠ j ∧ lt (fst r) adds⇩t l ∧ pair_in_list ps i k ∧ (q_in_bs ∨ pair_in_list ps j k) ∧ fst r ≠ 0) ∨ (∃h∈set hs. let k = fst (snd h) in k ≠ i ∧ k ≠ j ∧ lt (fst h) adds⇩t l ∧ pair_in_list ps i k ∧ pair_in_list ps j k ∧ fst h ≠ 0))" definition chain_ocrit :: "('t, 'b::zero, 'c, 'd) ocritT" where "chain_ocrit data hs ps p q ⟷ (let v = lt (fst p); l = term_of_pair (lcs (pp_of_term v) (lp (fst q)), component_of_term v); i = fst (snd p); j = fst (snd q) in (∃h∈set hs. let k = fst (snd h) in k ≠ i ∧ k ≠ j ∧ lt (fst h) adds⇩t l ∧ pair_in_list ps i k ∧ pair_in_list ps j k ∧ fst h ≠ 0))" text ‹@{const chain_ncrit} and @{const chain_ocrit} ignore the ‹data› parameter.› lemma chain_ncritE: assumes "chain_ncrit data gs bs hs q_in_bs ps p q" and "snd ` set ps ⊆ set hs × (set gs ∪ set bs ∪ set hs)" and "unique_idx (gs @ bs @ hs) data" and "p ∈ set hs" and "q ∈ set gs ∪ set bs ∪ set hs" obtains r where "r ∈ set gs ∪ set bs ∪ set hs" and "fst r ≠ 0" and "r ≠ p" and "r ≠ q" and "lt (fst r) adds⇩t term_of_pair (lcs (lp (fst p)) (lp (fst q)), component_of_term (lt (fst p)))" and "(p, r) ∈⇩p snd ` set ps" and "(r ∈ set gs ∪ set bs ∧ q_in_bs) ∨ (q, r) ∈⇩p snd ` set ps" proof - let ?l = "term_of_pair (lcs (lp (fst p)) (lp (fst q)), component_of_term (lt (fst p)))" let ?i = "fst (snd p)" let ?j = "fst (snd q)" let ?xs = "gs @ bs @ hs" have 3: "x ∈ set ?xs" if "(x, y) ∈⇩p snd ` set ps" for x y proof - note that also have "snd ` set ps ⊆ set hs × (set gs ∪ set bs ∪ set hs)" by (fact assms(2)) also have "... ⊆ (set gs ∪ set bs ∪ set hs) × (set gs ∪ set bs ∪ set hs)" by fastforce finally have "(x, y) ∈ (set gs ∪ set bs ∪ set hs) × (set gs ∪ set bs ∪ set hs)" by (simp only: in_pair_same) thus ?thesis by simp qed have 4: "x ∈ set ?xs" if "(y, x) ∈⇩p snd ` set ps" for x y proof - from that have "(x, y) ∈⇩p snd ` set ps" by (simp add: in_pair_iff disj_commute) thus ?thesis by (rule 3) qed from assms(1) have "∃r ∈ set gs ∪ set bs ∪ set hs. let k = fst (snd r) in k ≠ ?i ∧ k ≠ ?j ∧ lt (fst r) adds⇩t ?l ∧ pair_in_list ps ?i k ∧ ((r ∈ set gs ∪ set bs ∧ q_in_bs) ∨ pair_in_list ps ?j k) ∧ fst r ≠ 0" by (smt UnI1 chain_ncrit_def sup_commute) then obtain r where r_in: "r ∈ set gs ∪ set bs ∪ set hs" and "fst r ≠ 0" and rp: "fst (snd r) ≠ ?i" and rq: "fst (snd r) ≠ ?j" and "lt (fst r) adds⇩t ?l" and 1: "pair_in_list ps ?i (fst (snd r))" and 2: "(r ∈ set gs ∪ set bs ∧ q_in_bs) ∨ pair_in_list ps ?j (fst (snd r))" unfolding Let_def by blast let ?k = "fst (snd r)" note r_in ‹fst r ≠ 0› moreover from rp have "r ≠ p" by auto moreover from rq have "r ≠ q" by auto ultimately show ?thesis using ‹lt (fst r) adds⇩t ?l› proof from 1 obtain p' r' a b where *: "((p', ?i, a), (r', ?k, b)) ∈⇩p snd ` set ps" by (rule pair_in_listE) note assms(3) moreover from * have "(p', ?i, a) ∈ set ?xs" by (rule 3) moreover from assms(4) have "p ∈ set ?xs" by simp moreover have "fst (snd (p', ?i, a)) = ?i" by simp ultimately have p': "(p', ?i, a) = p" by (rule unique_idxD1) note assms(3) moreover from * have "(r', ?k, b) ∈ set ?xs" by (rule 4) moreover from r_in have "r ∈ set ?xs" by simp moreover have "fst (snd (r', ?k, b)) = ?k" by simp ultimately have r': "(r', ?k, b) = r" by (rule unique_idxD1) from * show "(p, r) ∈⇩p snd ` set ps" by (simp only: p' r') next from 2 show "(r ∈ set gs ∪ set bs ∧ q_in_bs) ∨ (q, r) ∈⇩p snd ` set ps" proof assume "r ∈ set gs ∪ set bs ∧ q_in_bs" thus ?thesis .. next assume "pair_in_list ps ?j ?k" then obtain q' r' a b where *: "((q', ?j, a), (r', ?k, b)) ∈⇩p snd ` set ps" by (rule pair_in_listE) note assms(3) moreover from * have "(q', ?j, a) ∈ set ?xs" by (rule 3) moreover from assms(5) have "q ∈ set ?xs" by simp moreover have "fst (snd (q', ?j, a)) = ?j" by simp ultimately have q': "(q', ?j, a) = q" by (rule unique_idxD1) note assms(3) moreover from * have "(r', ?k, b) ∈ set ?xs" by (rule 4) moreover from r_in have "r ∈ set ?xs" by simp moreover have "fst (snd (r', ?k, b)) = ?k" by simp ultimately have r': "(r', ?k, b) = r" by (rule unique_idxD1) from * have "(q, r) ∈⇩p snd ` set ps" by (simp only: q' r') thus ?thesis .. qed qed qed lemma chain_ocritE: assumes "chain_ocrit data hs ps p q" and "unique_idx (p # q # hs @ (map (fst ∘ snd) ps) @ (map (snd ∘ snd) ps)) data" (is "unique_idx ?xs _") obtains h where "h ∈ set hs" and "fst h ≠ 0" and "h ≠ p" and "h ≠ q" and "lt (fst h) adds⇩t term_of_pair (lcs (lp (fst p)) (lp (fst q)), component_of_term (lt (fst p)))" and "(p, h) ∈⇩p snd ` set ps" and "(q, h) ∈⇩p snd ` set ps" proof - let ?l = "term_of_pair (lcs (lp (fst p)) (lp (fst q)), component_of_term (lt (fst p)))" have 3: "x ∈ set ?xs" if "(x, y) ∈⇩p snd ` set ps" for x y proof - from that have "(x, y) ∈ snd ` set ps ∨ (y, x) ∈ snd ` set ps" by (simp only: in_pair_iff) thus ?thesis proof assume "(x, y) ∈ snd ` set ps" hence "fst (x, y) ∈ fst ` snd ` set ps" by fastforce thus ?thesis by (simp add: image_comp) next assume "(y, x) ∈ snd ` set ps" hence "snd (y, x) ∈ snd ` snd ` set ps" by fastforce thus ?thesis by (simp add: image_comp) qed qed have 4: "x ∈ set ?xs" if "(y, x) ∈⇩p snd ` set ps" for x y proof - from that have "(x, y) ∈⇩p snd ` set ps" by (simp add: in_pair_iff disj_commute) thus ?thesis by (rule 3) qed from assms(1) obtain h where "h ∈ set hs" and "fst h ≠ 0" and hp: "fst (snd h) ≠ fst (snd p)" and hq: "fst (snd h) ≠ fst (snd q)" and "lt (fst h) adds⇩t ?l" and 1: "pair_in_list ps (fst (snd p)) (fst (snd h))" and 2: "pair_in_list ps (fst (snd q)) (fst (snd h))" unfolding chain_ocrit_def Let_def by blast let ?i = "fst (snd p)" let ?j = "fst (snd q)" let ?k = "fst (snd h)" note ‹h ∈ set hs› ‹fst h ≠ 0› moreover from hp have "h ≠ p" by auto moreover from hq have "h ≠ q" by auto ultimately show ?thesis using ‹lt (fst h) adds⇩t ?l› proof from 1 obtain p' h' a b where *: "((p', ?i, a), (h', ?k, b)) ∈⇩p snd ` set ps" by (rule pair_in_listE) note assms(2) moreover from * have "(p', ?i, a) ∈ set ?xs" by (rule 3) moreover have "p ∈ set ?xs" by simp moreover have "fst (snd (p', ?i, a)) = ?i" by simp ultimately have p': "(p', ?i, a) = p" by (rule unique_idxD1) note assms(2) moreover from * have "(h', ?k, b) ∈ set ?xs" by (rule 4) moreover from ‹h ∈ set hs› have "h ∈ set ?xs" by simp moreover have "fst (snd (h', ?k, b)) = ?k" by simp ultimately have h': "(h', ?k, b) = h" by (rule unique_idxD1) from * show "(p, h) ∈⇩p snd ` set ps" by (simp only: p' h') next from 2 obtain q' h' a b where *: "((q', ?j, a), (h', ?k, b)) ∈⇩p snd ` set ps" by (rule pair_in_listE) note assms(2) moreover from * have "(q', ?j, a) ∈ set ?xs" by (rule 3) moreover have "q ∈ set ?xs" by simp moreover have "fst (snd (q', ?j, a)) = ?j" by simp ultimately have q': "(q', ?j, a) = q" by (rule unique_idxD1) note assms(2) moreover from * have "(h', ?k, b) ∈ set ?xs" by (rule 4) moreover from ‹h ∈ set hs› have "h ∈ set ?xs" by simp moreover have "fst (snd (h', ?k, b)) = ?k" by simp ultimately have h': "(h', ?k, b) = h" by (rule unique_idxD1) from * show "(q, h) ∈⇩p snd ` set ps" by (simp only: q' h') qed qed lemma ncrit_spec_chain_ncrit: "ncrit_spec (chain_ncrit::('t, 'b::field, 'c, 'd) ncritT)" proof (rule ncrit_specI) fix d m and data::"nat × 'd" and gs bs hs and ps::"(bool × ('t, 'b, 'c) pdata_pair) list" and B q_in_bs and p q::"('t, 'b, 'c) pdata" assume dg: "dickson_grading d" and B_sup: "set gs ∪ set bs ∪ set hs ⊆ B" and B_sub: "fst ` B ⊆ dgrad_p_set d m" and q_in_bs: "q_in_bs ⟶ q ∈ set gs ∪ set bs" and 1: "⋀p' q'. (p', q') ∈⇩p snd ` set ps ⟹ fst p' ≠ 0 ⟹ fst q' ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')" and 2: "⋀p' q'. p' ∈ set gs ∪ set bs ⟹ q' ∈ set gs ∪ set bs ⟹ fst p' ≠ 0 ⟹ fst q' ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')" and "fst p ≠ 0" and "fst q ≠ 0" let ?l = "term_of_pair (lcs (lp (fst p)) (lp (fst q)), component_of_term (lt (fst p)))" assume "chain_ncrit data gs bs hs q_in_bs ps p q" and "snd ` set ps ⊆ set hs × (set gs ∪ set bs ∪ set hs)" and "unique_idx (gs @ bs @ hs) data" and "p ∈ set hs" and "q ∈ set gs ∪ set bs ∪ set hs" then obtain r where "r ∈ set gs ∪ set bs ∪ set hs" and "fst r ≠ 0" and "r ≠ p" and "r ≠ q" and adds: "lt (fst r) adds⇩t ?l" and "(p, r) ∈⇩p snd ` set ps" and disj: "(r ∈ set gs ∪ set bs ∧ q_in_bs) ∨ (q, r) ∈⇩p snd ` set ps" by (rule chain_ncritE) note dg B_sub moreover from ‹p ∈ set hs› ‹q ∈ set gs ∪ set bs ∪ set hs› B_sup have "fst p ∈ fst ` B" and "fst q ∈ fst ` B" by auto moreover note ‹fst p ≠ 0› ‹fst q ≠ 0› moreover from adds have "lp (fst r) adds lcs (lp (fst p)) (lp (fst q))" by (simp add: adds_term_def term_simps) moreover from adds have "component_of_term (lt (fst r)) = component_of_term (lt (fst p))" by (simp add: adds_term_def term_simps) ultimately show "crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q)" proof (rule chain_criterion) from ‹(p, r) ∈⇩p snd ` set ps› ‹fst p ≠ 0› ‹fst r ≠ 0› show "crit_pair_cbelow_on d m (fst ` B) (fst p) (fst r)" by (rule 1) next from disj show "crit_pair_cbelow_on d m (fst ` B) (fst r) (fst q)" proof assume "r ∈ set gs ∪ set bs ∧ q_in_bs" hence "r ∈ set gs ∪ set bs" and q_in_bs by simp_all from q_in_bs this(2) have "q ∈ set gs ∪ set bs" .. with ‹r ∈ set gs ∪ set bs› show ?thesis using ‹fst r ≠ 0› ‹fst q ≠ 0› by (rule 2) next assume "(q, r) ∈⇩p snd ` set ps" hence "(r, q) ∈⇩p snd ` set ps" by (simp only: in_pair_iff disj_commute) thus ?thesis using ‹fst r ≠ 0› ‹fst q ≠ 0› by (rule 1) qed qed qed lemma ocrit_spec_chain_ocrit: "ocrit_spec (chain_ocrit::('t, 'b::field, 'c, 'd) ocritT)" proof (rule ocrit_specI) fix d m and data::"nat × 'd" and hs::"('t, 'b, 'c) pdata list" and ps::"(bool × ('t, 'b, 'c) pdata_pair) list" and B and p q::"('t, 'b, 'c) pdata" assume dg: "dickson_grading d" and B_sup: "set hs ⊆ B" and B_sub: "fst ` B ⊆ dgrad_p_set d m" and 1: "⋀p' q'. (p', q') ∈⇩p snd ` set ps ⟹ fst p' ≠ 0 ⟹ fst q' ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')" and "fst p ≠ 0" and "fst q ≠ 0" and "p ∈ B" and "q ∈ B" let ?l = "term_of_pair (lcs (lp (fst p)) (lp (fst q)), component_of_term (lt (fst p)))" assume "chain_ocrit data hs ps p q" and "unique_idx (p # q # hs @ map (fst ∘ snd) ps @ map (snd ∘ snd) ps) data" then obtain h where "h ∈ set hs" and "fst h ≠ 0" and "h ≠ p" and "h ≠ q" and adds: "lt (fst h) adds⇩t ?l" and "(p, h) ∈⇩p snd ` set ps" and "(q, h) ∈⇩p snd ` set ps" by (rule chain_ocritE) note dg B_sub moreover from ‹p ∈ B› ‹q ∈ B› B_sup have "fst p ∈ fst ` B" and "fst q ∈ fst ` B" by auto moreover note ‹fst p ≠ 0› ‹fst q ≠ 0› moreover from adds have "lp (fst h) adds lcs (lp (fst p)) (lp (fst q))" by (simp add: adds_term_def term_simps) moreover from adds have "component_of_term (lt (fst h)) = component_of_term (lt (fst p))" by (simp add: adds_term_def term_simps) ultimately show "crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q)" proof (rule chain_criterion) from ‹(p, h) ∈⇩p snd ` set ps› ‹fst p ≠ 0› ‹fst h ≠ 0› show "crit_pair_cbelow_on d m (fst ` B) (fst p) (fst h)" by (rule 1) next from ‹(q, h) ∈⇩p snd ` set ps› have "(h, q) ∈⇩p snd ` set ps" by (simp only: in_pair_iff disj_commute) thus "crit_pair_cbelow_on d m (fst ` B) (fst h) (fst q)" using ‹fst h ≠ 0› ‹fst q ≠ 0› by (rule 1) qed qed lemma icrit_spec_no_crit: "icrit_spec ((λ_ _ _ _ _ _. False)::('t, 'b::field, 'c, 'd) icritT)" by (rule icrit_specI, simp) lemma ncrit_spec_no_crit: "ncrit_spec ((λ_ _ _ _ _ _ _ _. False)::('t, 'b::field, 'c, 'd) ncritT)" by (rule ncrit_specI, simp) lemma ocrit_spec_no_crit: "ocrit_spec ((λ_ _ _ _ _. False)::('t, 'b::field, 'c, 'd) ocritT)" by (rule ocrit_specI, simp) subsubsection ‹Creating Initial List of New Pairs› type_synonym (in -) ('t, 'b, 'c) apsT = "bool ⇒ ('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata ⇒ (bool × ('t, 'b, 'c) pdata_pair) list ⇒ (bool × ('t, 'b, 'c) pdata_pair) list" type_synonym (in -) ('t, 'b, 'c, 'd) npT = "('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata list ⇒ nat × 'd ⇒ (bool × ('t, 'b, 'c) pdata_pair) list" definition np_spec :: "('t, 'b, 'c, 'd) npT ⇒ bool" where "np_spec np ⟷ (∀gs bs hs data. snd ` set (np gs bs hs data) ⊆ set hs × (set gs ∪ set bs ∪ set hs) ∧ set hs × (set gs ∪ set bs) ⊆ snd ` set (np gs bs hs data) ∧ (∀a b. a ∈ set hs ⟶ b ∈ set hs ⟶ a ≠ b ⟶ (a, b) ∈⇩p snd ` set (np gs bs hs data)) ∧ (∀p q. (True, p, q) ∈ set (np gs bs hs data) ⟶ q ∈ set gs ∪ set bs))" lemma np_specI: assumes "⋀gs bs hs data. snd ` set (np gs bs hs data) ⊆ set hs × (set gs ∪ set bs ∪ set hs) ∧ set hs × (set gs ∪ set bs) ⊆ snd ` set (np gs bs hs data) ∧ (∀a b. a ∈ set hs ⟶ b ∈ set hs ⟶ a ≠ b ⟶ (a, b) ∈⇩p snd ` set (np gs bs hs data)) ∧ (∀p q. (True, p, q) ∈ set (np gs bs hs data) ⟶ q ∈ set gs ∪ set bs)" shows "np_spec np" unfolding np_spec_def using assms by meson lemma np_specD1: assumes "np_spec np" shows "snd ` set (np gs bs hs data) ⊆ set hs × (set gs ∪ set bs ∪ set hs)" using assms[unfolded np_spec_def, rule_format, of gs bs hs data] .. lemma np_specD2: assumes "np_spec np" shows "set hs × (set gs ∪ set bs) ⊆ snd ` set (np gs bs hs data)" using assms[unfolded np_spec_def, rule_format, of gs bs hs data] by auto lemma np_specD3: assumes "np_spec np" and "a ∈ set hs" and "b ∈ set hs" and "a ≠ b" shows "(a, b) ∈⇩p snd ` set (np gs bs hs data)" using assms(1)[unfolded np_spec_def, rule_format, of gs bs hs data] assms(2,3,4) by blast lemma np_specD4: assumes "np_spec np" and "(True, p, q) ∈ set (np gs bs hs data)" shows "q ∈ set gs ∪ set bs" using assms(1)[unfolded np_spec_def, rule_format, of gs bs hs data] assms(2) by blast lemma np_specE: assumes "np_spec np" and "p ∈ set hs" and "q ∈ set gs ∪ set bs ∪ set hs" and "p ≠ q" assumes 1: "⋀q_in_bs. (q_in_bs, p, q) ∈ set (np gs bs hs data) ⟹ thesis" assumes 2: "⋀p_in_bs. (p_in_bs, q, p) ∈ set (np gs bs hs data) ⟹ thesis" shows thesis proof (cases "q ∈ set gs ∪ set bs") case True with assms(2) have "(p, q) ∈ set hs × (set gs ∪ set bs)" by simp also from assms(1) have "... ⊆ snd ` set (np gs bs hs data)" by (rule np_specD2) finally obtain q_in_bs where "(q_in_bs, p, q) ∈ set (np gs bs hs data)" by fastforce thus ?thesis by (rule 1) next case False with assms(3) have "q ∈ set hs" by simp from assms(1,2) this assms(4) have "(p, q) ∈⇩p snd ` set (np gs bs hs data)" by (rule np_specD3) hence "(p, q) ∈ snd ` set (np gs bs hs data) ∨ (q, p) ∈ snd ` set (np gs bs hs data)" by (simp only: in_pair_iff) thus ?thesis proof assume "(p, q) ∈ snd ` set (np gs bs hs data)" then obtain q_in_bs where "(q_in_bs, p, q) ∈ set (np gs bs hs data)" by fastforce thus ?thesis by (rule 1) next assume "(q, p) ∈ snd ` set (np gs bs hs data)" then obtain p_in_bs where "(p_in_bs, q, p) ∈ set (np gs bs hs data)" by fastforce thus ?thesis by (rule 2) qed qed definition add_pairs_single_naive :: "'d ⇒ ('t, 'b::zero, 'c) apsT" where "add_pairs_single_naive data flag gs bs h ps = ps @ (map (λg. (flag, h, g)) gs) @ (map (λb. (flag, h, b)) bs)" lemma set_add_pairs_single_naive: "set (add_pairs_single_naive data flag gs bs h ps) = set ps ∪ Pair flag ` ({h} × (set gs ∪ set bs))" by (auto simp add: add_pairs_single_naive_def Let_def) fun add_pairs_single_sorted :: "((bool × ('t, 'b, 'c) pdata_pair) ⇒ (bool × ('t, 'b, 'c) pdata_pair) ⇒ bool) ⇒ ('t, 'b::zero, 'c) apsT" where "add_pairs_single_sorted _ _ [] [] _ ps = ps"| "add_pairs_single_sorted rel flag [] (b # bs) h ps = add_pairs_single_sorted rel flag [] bs h (insort_wrt rel (flag, h, b) ps)"| "add_pairs_single_sorted rel flag (g # gs) bs h ps = add_pairs_single_sorted rel flag gs bs h (insort_wrt rel (flag, h, g) ps)" lemma set_add_pairs_single_sorted: "set (add_pairs_single_sorted rel flag gs bs h ps) = set ps ∪ Pair flag ` ({h} × (set gs ∪ set bs))" proof (induct gs arbitrary: ps) case Nil show ?case proof (induct bs arbitrary: ps) case Nil show ?case by simp next case (Cons b bs) show ?case by (simp add: Cons) qed next case (Cons g gs) show ?case by (simp add: Cons) qed primrec (in -) pairs :: "('t, 'b, 'c) apsT ⇒ bool ⇒ ('t, 'b, 'c) pdata list ⇒ (bool × ('t, 'b, 'c) pdata_pair) list" where "pairs _ _ [] = []"| "pairs aps flag (x # xs) = aps flag [] xs x (pairs aps flag xs)" lemma pairs_subset: assumes "⋀gs bs h ps. set (aps flag gs bs h ps) = set ps ∪ Pair flag ` ({h} × (set gs ∪ set bs))" shows "set (pairs aps flag xs) ⊆ Pair flag ` (set xs × set xs)" proof (induct xs) case Nil show ?case by simp next case (Cons x xs) from Cons have "set (pairs aps flag xs) ⊆ Pair flag ` (set (x # xs) × set (x # xs))" by fastforce moreover have "{x} × set xs ⊆ set (x # xs) × set (x # xs)" by fastforce ultimately show ?case by (auto simp add: assms) qed lemma in_pairsI: assumes "⋀gs bs h ps. set (aps flag gs bs h ps) = set ps ∪ Pair flag ` ({h} × (set gs ∪ set bs))" and "a ≠ b" and "a ∈ set xs" and "b ∈ set xs" shows "(flag, a, b) ∈ set (pairs aps flag xs) ∨ (flag, b, a) ∈ set (pairs aps flag xs)" using assms(3, 4) proof (induct xs) case Nil thus ?case by simp next case (Cons x xs) from Cons(3) have d: "b = x ∨ b ∈ set xs" by simp from Cons(2) have "a = x ∨ a ∈ set xs" by simp thus ?case proof assume "a = x" with assms(2) have "b ≠ x" by simp with d have "b ∈ set xs" by simp hence "(flag, a, b) ∈ set (pairs aps flag (x # xs))" by (simp add: ‹a = x› assms(1)) thus ?thesis by simp next assume "a ∈ set xs" from d show ?thesis proof assume "b = x" from ‹a ∈ set xs› have "(flag, b, a) ∈ set (pairs aps flag (x # xs))" by (simp add: ‹b = x› assms(1)) thus ?thesis by simp next assume "b ∈ set xs" with ‹a ∈ set xs› have "(flag, a, b) ∈ set (pairs aps flag xs) ∨ (flag, b, a) ∈ set (pairs aps flag xs)" by (rule Cons(1)) thus ?thesis by (auto simp: assms(1)) qed qed qed corollary in_pairsI': assumes "⋀gs bs h ps. set (aps flag gs bs h ps) = set ps ∪ Pair flag ` ({h} × (set gs ∪ set bs))" and "a ∈ set xs" and "b ∈ set xs" and "a ≠ b" shows "(a, b) ∈⇩p snd ` set (pairs aps flag xs)" proof - from assms(1,4,2,3) have "(flag, a, b) ∈ set (pairs aps flag xs) ∨ (flag, b, a) ∈ set (pairs aps flag xs)" by (rule in_pairsI) thus ?thesis proof assume "(flag, a, b) ∈ set (pairs aps flag xs)" hence "snd (flag, a, b) ∈ snd ` set (pairs aps flag xs)" by fastforce thus ?thesis by (simp add: in_pair_iff) next assume "(flag, b, a) ∈ set (pairs aps flag xs)" hence "snd (flag, b, a) ∈ snd ` set (pairs aps flag xs)" by fastforce thus ?thesis by (simp add: in_pair_iff) qed qed definition new_pairs_naive :: "('t, 'b::zero, 'c, 'd) npT" where "new_pairs_naive gs bs hs data = fold (add_pairs_single_naive data True gs bs) hs (pairs (add_pairs_single_naive data) False hs)" definition new_pairs_sorted :: "(nat × 'd ⇒ (bool × ('t, 'b, 'c) pdata_pair) ⇒ (bool × ('t, 'b, 'c) pdata_pair) ⇒ bool) ⇒ ('t, 'b::zero, 'c, 'd) npT" where "new_pairs_sorted rel gs bs hs data = fold (add_pairs_single_sorted (rel data) True gs bs) hs (pairs (add_pairs_single_sorted (rel data)) False hs)" lemma set_fold_aps: assumes "⋀gs bs h ps. set (aps flag gs bs h ps) = set ps ∪ Pair flag ` ({h} × (set gs ∪ set bs))" shows "set (fold (aps flag gs bs) hs ps) = Pair flag ` (set hs × (set gs ∪ set bs)) ∪ set ps" proof (induct hs arbitrary: ps) case Nil show ?case by simp next case (Cons h hs) show ?case by (auto simp add: Cons assms) qed lemma set_new_pairs_naive: "set (new_pairs_naive gs bs hs data) = Pair True ` (set hs × (set gs ∪ set bs)) ∪ set (pairs (add_pairs_single_naive data) False hs)" proof - have "set (new_pairs_naive gs bs hs data) = Pair True ` (set hs × (set gs ∪ set bs)) ∪ set (pairs (add_pairs_single_naive data) False hs)" unfolding new_pairs_naive_def by (rule set_fold_aps, fact set_add_pairs_single_naive) thus ?thesis by (simp add: ac_simps) qed lemma set_new_pairs_sorted: "set (new_pairs_sorted rel gs bs hs data) = Pair True ` (set hs × (set gs ∪ set bs)) ∪ set (pairs (add_pairs_single_sorted (rel data)) False hs)" proof - have "set (new_pairs_sorted rel gs bs hs data) = Pair True ` (set hs × (set gs ∪ set bs)) ∪ set (pairs (add_pairs_single_sorted (rel data)) False hs)" unfolding new_pairs_sorted_def by (rule set_fold_aps, fact set_add_pairs_single_sorted) thus ?thesis by (simp add: set_merge_wrt ac_simps) qed lemma (in -) fst_snd_Pair [simp]: shows "fst ∘ Pair x = (λ_. x)" and "snd ∘ Pair x = id" by auto lemma np_spec_new_pairs_naive: "np_spec new_pairs_naive" proof (rule np_specI) fix gs bs hs :: "('t, 'b, 'c) pdata list" and data::"nat × 'd" have 1: "set hs × (set gs ∪ set bs) ⊆ set hs × (set gs ∪ set bs ∪ set hs)" by fastforce have "set (pairs (add_pairs_single_naive data) False hs) ⊆ Pair False ` (set hs × set hs)" by (rule pairs_subset, simp add: set_add_pairs_single_naive) hence "snd ` set (pairs (add_pairs_single_naive data) False hs) ⊆ snd ` Pair False ` (set hs × set hs)" by (rule image_mono) also have "... = set hs × set hs" by (simp add: image_comp) finally have 2: "snd ` set (pairs (add_pairs_single_naive data) False hs) ⊆ set hs × (set gs ∪ set bs ∪ set hs)" by fastforce show "snd ` set (new_pairs_naive gs bs hs data) ⊆ set hs × (set gs ∪ set bs ∪ set hs) ∧ set hs × (set gs ∪ set bs) ⊆ snd ` set (new_pairs_naive gs bs hs data) ∧ (∀a b. a ∈ set hs ⟶ b ∈ set hs ⟶ a ≠ b ⟶ (a, b) ∈⇩p snd ` set (new_pairs_naive gs bs hs data)) ∧ (∀p q. (True, p, q) ∈ set (new_pairs_naive gs bs hs data) ⟶ q ∈ set gs ∪ set bs)" proof (intro conjI allI impI) show "snd ` set (new_pairs_naive gs bs hs data) ⊆ set hs × (set gs ∪ set bs ∪ set hs)" by (simp add: set_new_pairs_naive image_Un image_comp 1 2) next show "set hs × (set gs ∪ set bs) ⊆ snd ` set (new_pairs_naive gs bs hs data)" by (simp add: set_new_pairs_naive image_Un image_comp) next fix a b assume "a ∈ set hs" and "b ∈ set hs" and "a ≠ b" with set_add_pairs_single_naive have "(a, b) ∈⇩p snd ` set (pairs (add_pairs_single_naive data) False hs)" by (rule in_pairsI') thus "(a, b) ∈⇩p snd ` set (new_pairs_naive gs bs hs data)" by (simp add: set_new_pairs_naive image_Un) next fix p q assume "(True, p, q) ∈ set (new_pairs_naive gs bs hs data)" hence "q ∈ set gs ∪ set bs ∨ (True, p, q) ∈ set (pairs (add_pairs_single_naive data) False hs)" by (auto simp: set_new_pairs_naive) thus "q ∈ set gs ∪ set bs" proof assume "(True, p, q) ∈ set (pairs (add_pairs_single_naive data) False hs)" also from set_add_pairs_single_naive have "... ⊆ Pair False ` (set hs × set hs)" by (rule pairs_subset) finally show ?thesis by auto qed qed qed lemma np_spec_new_pairs_sorted: "np_spec (new_pairs_sorted rel)" proof (rule np_specI) fix gs bs hs :: "('t, 'b, 'c) pdata list" and data::"nat × 'd" have 1: "set hs × (set gs ∪ set bs) ⊆ set hs × (set gs ∪ set bs ∪ set hs)" by fastforce have "set (pairs (add_pairs_single_sorted (rel data)) False hs) ⊆ Pair False ` (set hs × set hs)" by (rule pairs_subset, simp add: set_add_pairs_single_sorted) hence "snd ` set (pairs (add_pairs_single_sorted (rel data)) False hs) ⊆ snd ` Pair False ` (set hs × set hs)" by (rule image_mono) also have "... = set hs × set hs" by (simp add: image_comp) finally have 2: "snd ` set (pairs (add_pairs_single_sorted (rel data)) False hs) ⊆ set hs × (set gs ∪ set bs ∪ set hs)" by fastforce show "snd ` set (new_pairs_sorted rel gs bs hs data) ⊆ set hs × (set gs ∪ set bs ∪ set hs) ∧ set hs × (set gs ∪ set bs) ⊆ snd ` set (new_pairs_sorted rel gs bs hs data) ∧ (∀a b. a ∈ set hs ⟶ b ∈ set hs ⟶ a ≠ b ⟶ (a, b) ∈⇩p snd ` set (new_pairs_sorted rel gs bs hs data)) ∧ (∀p q. (True, p, q) ∈ set (new_pairs_sorted rel gs bs hs data) ⟶ q ∈ set gs ∪ set bs)" proof (intro conjI allI impI) show "snd ` set (new_pairs_sorted rel gs bs hs data) ⊆ set hs × (set gs ∪ set bs ∪ set hs)" by (simp add: set_new_pairs_sorted image_Un image_comp 1 2) next show "set hs × (set gs ∪ set bs) ⊆ snd ` set (new_pairs_sorted rel gs bs hs data)" by (simp add: set_new_pairs_sorted image_Un image_comp) next fix a b assume "a ∈ set hs" and "b ∈ set hs" and "a ≠ b" with set_add_pairs_single_sorted have "(a, b) ∈⇩p snd ` set (pairs (add_pairs_single_sorted (rel data)) False hs)" by (rule in_pairsI') thus "(a, b) ∈⇩p snd ` set (new_pairs_sorted rel gs bs hs data)" by (simp add: set_new_pairs_sorted image_Un) next fix p q assume "(True, p, q) ∈ set (new_pairs_sorted rel gs bs hs data)" hence "q ∈ set gs ∪ set bs ∨ (True, p, q) ∈ set (pairs (add_pairs_single_sorted (rel data)) False hs)" by (auto simp: set_new_pairs_sorted) thus "q ∈ set gs ∪ set bs" proof assume "(True, p, q) ∈ set (pairs (add_pairs_single_sorted (rel data)) False hs)" also from set_add_pairs_single_sorted have "... ⊆ Pair False ` (set hs × set hs)" by (rule pairs_subset) finally show ?thesis by auto qed qed qed text ‹@{term "new_pairs_naive gs bs hs data"} and @{term "new_pairs_sorted rel gs bs hs data"} return lists of triples @{term "(q_in_bs, p, q)"}, where ‹q_in_bs› indicates whether ‹q› is contained in the list @{term "gs @ bs"} or in the list ‹hs›. ‹p› is always contained in ‹hs›.› definition canon_pair_order_aux :: "('t, 'b::zero, 'c) pdata_pair ⇒ ('t, 'b, 'c) pdata_pair ⇒ bool" where "canon_pair_order_aux p q ⟷ (lcs (lp (fst (fst p))) (lp (fst (snd p))) ≼ lcs (lp (fst (fst q))) (lp (fst (snd q))))" abbreviation "canon_pair_order data p q ≡ canon_pair_order_aux (snd p) (snd q)" abbreviation "canon_pair_comb ≡ merge_wrt canon_pair_order_aux" subsubsection ‹Applying Criteria to New Pairs› definition apply_icrit :: "('t, 'b, 'c, 'd) icritT ⇒ (nat × 'd) ⇒ ('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata list ⇒ (bool × ('t, 'b, 'c) pdata_pair) list ⇒ (bool × bool × ('t, 'b, 'c) pdata_pair) list" where "apply_icrit crit data gs bs hs ps = (let c = crit data gs bs hs in map (λ(q_in_bs, p, q). (c p q, q_in_bs, p, q)) ps)" lemma fst_apply_icrit: assumes "icrit_spec crit" and "dickson_grading d" and "fst ` (set gs ∪ set bs ∪ set hs) ⊆ dgrad_p_set d m" and "unique_idx (gs @ bs @ hs) data" and "is_Groebner_basis (fst ` set gs)" and "p ∈ set hs" and "q ∈ set gs ∪ set bs ∪ set hs" and "fst p ≠ 0" and "fst q ≠ 0" and "(True, q_in_bs, p, q) ∈ set (apply_icrit crit data gs bs hs ps)" shows "crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs ∪ set hs)) (fst p) (fst q)" proof - from assms(10) have "crit data gs bs hs p q" by (auto simp: apply_icrit_def) with assms(1-9) show ?thesis by (rule icrit_specD) qed lemma snd_apply_icrit [simp]: "map snd (apply_icrit crit data gs bs hs ps) = ps" by (auto simp add: apply_icrit_def case_prod_beta' intro: nth_equalityI) lemma set_snd_apply_icrit [simp]: "snd ` set (apply_icrit crit data gs bs hs ps) = set ps" proof - have "snd ` set (apply_icrit crit data gs bs hs ps) = set (map snd (apply_icrit crit data gs bs hs ps))" by (simp del: snd_apply_icrit) also have "... = set ps" by (simp only: snd_apply_icrit) finally show ?thesis . qed definition apply_ncrit :: "('t, 'b, 'c, 'd) ncritT ⇒ (nat × 'd) ⇒ ('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata list ⇒ (bool × bool × ('t, 'b, 'c) pdata_pair) list ⇒ (bool × ('t, 'b, 'c) pdata_pair) list" where "apply_ncrit crit data gs bs hs ps = (let c = crit data gs bs hs in rev (fold (λ(ic, q_in_bs, p, q). λps'. if ¬ ic ∧ c q_in_bs ps' p q then ps' else (ic, p, q) # ps') ps []))" lemma apply_ncrit_append: "apply_ncrit crit data gs bs hs (xs @ ys) = rev (fold (λ(ic, q_in_bs, p, q). λps'. if ¬ ic ∧ crit data gs bs hs q_in_bs ps' p q then ps' else (ic, p, q) # ps') ys (rev (apply_ncrit crit data gs bs hs xs)))" by (simp add: apply_ncrit_def Let_def) lemma fold_superset: "set acc ⊆ set (fold (λ(ic, q_in_bs, p, q). λps'. if ¬ ic ∧ c q_in_bs ps' p q then ps' else (ic, p, q) # ps') ps acc)" proof (induct ps arbitrary: acc) case Nil show ?case by simp next case (Cons x ps) obtain ic' q_in_bs' p' q' where x: "x = (ic', q_in_bs', p', q')" using prod_cases4 by blast have 1: "set acc0 ⊆ set (fold (λ(ic, q_in_bs, p, q) ps'. if ¬ ic ∧ c q_in_bs ps' p q then ps' else (ic, p, q) # ps') ps acc0)" for acc0 by (rule Cons) have "set acc ⊆ set ((ic', p', q') # acc)" by fastforce also have "... ⊆ set (fold (λ(ic, q_in_bs, p, q) ps'. if ¬ ic ∧ c q_in_bs ps' p q then ps' else (ic, p, q) # ps') ps ((ic', p', q') # acc))" by (fact 1) finally have 2: "set acc ⊆ set (fold (λ(ic, q_in_bs, p, q) ps'. if ¬ ic ∧ c q_in_bs ps' p q then ps' else (ic, p, q) # ps') ps ((ic', p', q') # acc))" . show ?case by (simp add: x 1 2) qed lemma apply_ncrit_superset: "set (apply_ncrit crit data gs bs hs ps) ⊆ set (apply_ncrit crit data gs bs hs (ps @ qs))" (is "?l ⊆ ?r") proof - have "?l = set (rev (apply_ncrit crit data gs bs hs ps))" by simp also have "... ⊆ set (fold (λ(ic, q_in_bs, p, q) ps'. if ¬ ic ∧ crit data gs bs hs q_in_bs ps' p q then ps' else (ic, p, q) # ps') qs (rev (apply_ncrit crit data gs bs hs ps)))" by (fact fold_superset) also have "... = ?r" by (simp add: apply_ncrit_append) finally show ?thesis . qed lemma apply_ncrit_subset_aux: assumes "(ic, p, q) ∈ set (fold (λ(ic, q_in_bs, p, q). λps'. if ¬ ic ∧ c q_in_bs ps' p q then ps' else (ic, p, q) # ps') ps acc)" shows "(ic, p, q) ∈ set acc ∨ (∃q_in_bs. (ic, q_in_bs, p, q) ∈ set ps)" using assms proof (induct ps arbitrary: acc) case Nil thus ?case by simp next case (Cons x ps) obtain ic' q_in_bs' p' q' where x: "x = (ic', q_in_bs', p', q')" using prod_cases4 by blast from Cons(2) have "(ic, p, q) ∈ set (fold (λ(ic, q_in_bs, p, q) ps'. if ¬ ic ∧ c q_in_bs ps' p q then ps' else (ic, p, q) # ps') ps (if ¬ ic' ∧ c q_in_bs' acc p' q' then acc else (ic', p', q') # acc))" by (simp add: x) hence "(ic, p, q) ∈ set (if ¬ ic' ∧ c q_in_bs' acc p' q' then acc else (ic', p', q') # acc) ∨ (∃q_in_bs. (ic, q_in_bs, p, q) ∈ set ps)" by (rule Cons(1)) hence "(ic, p, q) ∈ set acc ∨ (ic, p, q) = (ic', p', q') ∨ (∃q_in_bs. (ic, q_in_bs, p, q) ∈ set ps)" by (auto split: if_splits) thus ?case proof (elim disjE) assume "(ic, p, q) ∈ set acc" thus ?thesis .. next assume "(ic, p, q) = (ic', p', q')" hence "x = (ic, q_in_bs', p, q)" by (simp add: x) thus ?thesis by auto next assume "∃q_in_bs. (ic, q_in_bs, p, q) ∈ set ps" then obtain q_in_bs where "(ic, q_in_bs, p, q) ∈ set ps" .. thus ?thesis by auto qed qed corollary apply_ncrit_subset: assumes "(ic, p, q) ∈ set (apply_ncrit crit data gs bs hs ps)" obtains q_in_bs where "(ic, q_in_bs, p, q) ∈ set ps" proof - from assms have "(ic, p, q) ∈ set (fold (λ(ic, q_in_bs, p, q). λps'. if ¬ ic ∧ crit data gs bs hs q_in_bs ps' p q then ps' else (ic, p, q) # ps') ps [])" by (simp add: apply_ncrit_def) hence "(ic, p, q) ∈ set [] ∨ (∃q_in_bs. (ic, q_in_bs, p, q) ∈ set ps)" by (rule apply_ncrit_subset_aux) hence "∃q_in_bs. (ic, q_in_bs, p, q) ∈ set ps" by simp then obtain q_in_bs where "(ic, q_in_bs, p, q) ∈ set ps" .. thus ?thesis .. qed corollary apply_ncrit_subset': "snd ` set (apply_ncrit crit data gs bs hs ps) ⊆ snd ` snd ` set ps" proof fix p q assume "(p, q) ∈ snd ` set (apply_ncrit crit data gs bs hs ps)" then obtain ic where "(ic, p, q) ∈ set (apply_ncrit crit data gs bs hs ps)" by fastforce then obtain q_in_bs where "(ic, q_in_bs, p, q) ∈ set ps" by (rule apply_ncrit_subset) thus "(p, q) ∈ snd ` snd ` set ps" by force qed lemma not_in_apply_ncrit: assumes "(ic, p, q) ∉ set (apply_ncrit crit data gs bs hs (xs @ ((ic, q_in_bs, p, q) # ys)))" shows "crit data gs bs hs q_in_bs (rev (apply_ncrit crit data gs bs hs xs)) p q" using assms proof (simp add: apply_ncrit_append split: if_splits) assume "(ic, p, q) ∉ set (fold (λ(ic, q_in_bs, p, q) ps'. if ¬ ic ∧ crit data gs bs hs q_in_bs ps' p q then ps' else (ic, p, q) # ps') ys ((ic, p, q) # rev (apply_ncrit crit data gs bs hs xs)))" (is "_ ∉ ?A") have "(ic, p, q) ∈ set ((ic, p, q) # rev (apply_ncrit crit data gs bs hs xs))" by simp also have "... ⊆ ?A" by (rule fold_superset) finally have "(ic, p, q) ∈ ?A" . with ‹(ic, p, q) ∉ ?A› show ?thesis .. qed lemma (in -) setE: assumes "x ∈ set xs" obtains ys zs where "xs = ys @ (x # zs)" using assms proof (induct xs arbitrary: thesis) case Nil from Nil(2) show ?case by simp next case (Cons a xs) from Cons(3) have "x = a ∨ x ∈ set xs" by simp thus ?case proof assume "x = a" show ?thesis by (rule Cons(2)[of "[]" xs], simp add: ‹x = a›) next assume "x ∈ set xs" then obtain ys zs where "xs = ys @ (x # zs)" by (meson Cons(1)) show ?thesis by (rule Cons(2)[of "a # ys" zs], simp add: ‹xs = ys @ (x # zs)›) qed qed lemma apply_ncrit_connectible: assumes "ncrit_spec crit" and "dickson_grading d" and "set gs ∪ set bs ∪ set hs ⊆ B" and "fst ` B ⊆ dgrad_p_set d m" and "snd ` snd ` set ps ⊆ set hs × (set gs ∪ set bs ∪ set hs)" and "unique_idx (gs @ bs @ hs) data" and "is_Groebner_basis (fst ` set gs)" and "⋀p' q'. (p', q') ∈ snd ` set (apply_ncrit crit data gs bs hs ps) ⟹ fst p' ≠ 0 ⟹ fst q' ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')" and "⋀p' q'. p' ∈ set gs ∪ set bs ⟹ q' ∈ set gs ∪ set bs ⟹ fst p' ≠ 0 ⟹ fst q' ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')" assumes "(ic, q_in_bs, p, q) ∈ set ps" and "fst p ≠ 0" and "fst q ≠ 0" and "q_in_bs ⟹ (q ∈ set gs ∪ set bs)" shows "crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q)" proof (cases "(p, q) ∈ snd ` set (apply_ncrit crit data gs bs hs ps)") case True thus ?thesis using assms(11,12) by (rule assms(8)) next case False from assms(10) have "(p, q) ∈ snd ` snd ` set ps" by force also have "... ⊆ set hs × (set gs ∪ set bs ∪ set hs)" by (fact assms(5)) finally have "p ∈ set hs" and "q ∈ set gs ∪ set bs ∪ set hs" by simp_all from ‹(ic, q_in_bs, p, q) ∈ set ps› obtain xs ys where ps: "ps = xs @ ((ic, q_in_bs, p, q) # ys)" by (rule setE) let ?ps = "rev (apply_ncrit crit data gs bs hs xs)" have "snd ` set ?ps ⊆ snd ` snd ` set xs" by (simp add: apply_ncrit_subset') also have "... ⊆ snd ` snd ` set ps" unfolding ps by fastforce finally have sub: "snd ` set ?ps ⊆ set hs × (set gs ∪ set bs ∪ set hs)" using assms(5) by (rule subset_trans) from False have "(p, q) ∉ snd ` set (apply_ncrit crit data gs bs hs ps)" by (simp add: in_pair_iff) hence "(ic, p, q) ∉ set (apply_ncrit crit data gs bs hs (xs @ ((ic, q_in_bs, p, q) # ys)))" unfolding ps by force hence "crit data gs bs hs q_in_bs ?ps p q" by (rule not_in_apply_ncrit) with assms(1-4) sub assms(6,7,13) _ _ ‹p ∈ set hs› ‹q ∈ set gs ∪ set bs ∪ set hs› assms(11,12) show ?thesis proof (rule ncrit_specD) fix p' q' assume "(p', q') ∈⇩p snd ` set ?ps" also have "... ⊆ snd ` set (apply_ncrit crit data gs bs hs ps)" by (rule image_mono, simp add: ps apply_ncrit_superset) finally have disj: "(p', q') ∈ snd ` set (apply_ncrit crit data gs bs hs ps) ∨ (q', p') ∈ snd ` set (apply_ncrit crit data gs bs hs ps)" by (simp only: in_pair_iff) assume "fst p' ≠ 0" and "fst q' ≠ 0" from disj show "crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')" proof assume "(p', q') ∈ snd ` set (apply_ncrit crit data gs bs hs ps)" thus ?thesis using ‹fst p' ≠ 0› ‹fst q' ≠ 0› by (rule assms(8)) next assume "(q', p') ∈ snd ` set (apply_ncrit crit data gs bs hs ps)" hence "crit_pair_cbelow_on d m (fst ` B) (fst q') (fst p')" using ‹fst q' ≠ 0› ‹fst p' ≠ 0› by (rule assms(8)) thus ?thesis by (rule crit_pair_cbelow_sym) qed qed (assumption, fact assms(9)) qed subsubsection ‹Applying Criteria to Old Pairs› definition apply_ocrit :: "('t, 'b, 'c, 'd) ocritT ⇒ (nat × 'd) ⇒ ('t, 'b, 'c) pdata list ⇒ (bool × ('t, 'b, 'c) pdata_pair) list ⇒ ('t, 'b, 'c) pdata_pair list ⇒ ('t, 'b, 'c) pdata_pair list" where "apply_ocrit crit data hs ps' ps = (let c = crit data hs ps' in [(p, q)←ps . ¬ c p q])" lemma set_apply_ocrit: "set (apply_ocrit crit data hs ps' ps) = {(p, q) | p q. (p, q) ∈ set ps ∧ ¬ crit data hs ps' p q}" by (auto simp: apply_ocrit_def) corollary set_apply_ocrit_iff: "(p, q) ∈ set (apply_ocrit crit data hs ps' ps) ⟷ ((p, q) ∈ set ps ∧ ¬ crit data hs ps' p q)" by (auto simp: apply_ocrit_def) lemma apply_ocrit_connectible: assumes "ocrit_spec crit" and "dickson_grading d" and "set hs ⊆ B" and "fst ` B ⊆ dgrad_p_set d m" and "unique_idx (p # q # hs @ (map (fst ∘ snd) ps') @ (map (snd ∘ snd) ps')) data" and "⋀p' q'. (p', q') ∈ snd ` set ps' ⟹ fst p' ≠ 0 ⟹ fst q' ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')" assumes "p ∈ B" and "q ∈ B" and "fst p ≠ 0" and "fst q ≠ 0" and "(p, q) ∈ set ps" and "(p, q) ∉ set (apply_ocrit crit data hs ps' ps)" shows "crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q)" proof - from assms(11,12) have "crit data hs ps' p q" by (simp add: set_apply_ocrit_iff) with assms(1-5) _ assms(7-10) show ?thesis proof (rule ocrit_specD) fix p' q' assume "(p', q') ∈⇩p snd ` set ps'" hence disj: "(p', q') ∈ snd ` set ps' ∨ (q', p') ∈ snd ` set ps'" by (simp only: in_pair_iff) assume "fst p' ≠ 0" and "fst q' ≠ 0" from disj show "crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')" proof assume "(p', q') ∈ snd ` set ps'" thus ?thesis using ‹fst p' ≠ 0› ‹fst q' ≠ 0› by (rule assms(6)) next assume "(q', p') ∈ snd ` set ps'" hence "crit_pair_cbelow_on d m (fst ` B) (fst q') (fst p')" using ‹fst q' ≠ 0› ‹fst p' ≠ 0› by (rule assms(6)) thus ?thesis by (rule crit_pair_cbelow_sym) qed qed qed subsubsection ‹Creating Final List of Pairs› context fixes np::"('t, 'b::field, 'c, 'd) npT" and icrit::"('t, 'b, 'c, 'd) icritT" and ncrit::"('t, 'b, 'c, 'd) ncritT" and ocrit::"('t, 'b, 'c, 'd) ocritT" and comb::"('t, 'b, 'c) pdata_pair list ⇒ ('t, 'b, 'c) pdata_pair list ⇒ ('t, 'b, 'c) pdata_pair list" begin definition add_pairs :: "('t, 'b, 'c, 'd) apT" where "add_pairs gs bs ps hs data = (let ps1 = apply_ncrit ncrit data gs bs hs (apply_icrit icrit data gs bs hs (np gs bs hs data)); ps2 = apply_ocrit ocrit data hs ps1 ps in comb (map snd [x←ps1 . ¬ fst x]) ps2)" lemma set_add_pairs: assumes "⋀xs ys. set (comb xs ys) = set xs ∪ set ys" assumes "ps1 = apply_ncrit ncrit data gs bs hs (apply_icrit icrit data gs bs hs (np gs bs hs data))" shows "set (add_pairs gs bs ps hs data) = {(p, q) | p q. (False, p, q) ∈ set ps1 ∨ ((p, q) ∈ set ps ∧ ¬ ocrit data hs ps1 p q)}" proof - have eq: "snd ` {x ∈ set ps1. ¬ fst x} = {(p, q) | p q. (False, p, q) ∈ set ps1}" by force thus ?thesis by (auto simp: add_pairs_def Let_def assms(1) assms(2)[symmetric] set_apply_ocrit) qed lemma set_add_pairs_iff: assumes "⋀xs ys. set (comb xs ys) = set xs ∪ set ys" assumes "ps1 = apply_ncrit ncrit data gs bs hs (apply_icrit icrit data gs bs hs (np gs bs hs data))" shows "((p, q) ∈ set (add_pairs gs bs ps hs data)) ⟷ ((False, p, q) ∈ set ps1 ∨ ((p, q) ∈ set ps ∧ ¬ ocrit data hs ps1 p q))" proof - from assms have eq: "set (add_pairs gs bs ps hs data) = {(p, q) | p q. (False, p, q) ∈ set ps1 ∨ ((p, q) ∈ set ps ∧ ¬ ocrit data hs ps1 p q)}" by (rule set_add_pairs) obtain a aa b where p: "p = (a, aa, b)" using prod_cases3 by blast obtain ab ac ba where q: "q = (ab, ac, ba)" using prod_cases3 by blast show ?thesis by (simp add: eq p q) qed lemma ap_spec_add_pairs: assumes "np_spec np" and "icrit_spec icrit" and "ncrit_spec ncrit" and "ocrit_spec ocrit" and "⋀xs ys. set (comb xs ys) = set xs ∪ set ys" shows "ap_spec add_pairs" proof (rule ap_specI) fix gs bs :: "('t, 'b, 'c) pdata list" and ps hs and data::"nat × 'd" define ps1 where "ps1 = apply_ncrit ncrit data gs bs hs (apply_icrit icrit data gs bs hs (np gs bs hs data))" show "set (add_pairs gs bs ps hs data) ⊆ set ps ∪ set hs × (set gs ∪ set bs ∪ set hs)" proof fix p q assume "(p, q) ∈ set (add_pairs gs bs ps hs data)" with assms(5) ps1_def have "(False, p, q) ∈ set ps1 ∨ ((p, q) ∈ set ps ∧ ¬ ocrit data hs ps1 p q)" by (simp add: set_add_pairs_iff) thus "(p, q) ∈ set ps ∪ set hs × (set gs ∪ set bs ∪ set hs)" proof assume "(False, p, q) ∈ set ps1" hence "snd (False, p, q) ∈ snd ` set ps1" by fastforce hence "(p, q) ∈ snd ` set ps1" by simp also have "... ⊆ snd ` snd ` set (apply_icrit icrit data gs bs hs (np gs bs hs data))" unfolding ps1_def by (fact apply_ncrit_subset') also have "... = snd ` set (np gs bs hs data)" by simp also from assms(1) have "... ⊆ set hs × (set gs ∪ set bs ∪ set hs)" by (rule np_specD1) finally show ?thesis .. next assume "(p, q) ∈ set ps ∧ ¬ ocrit data hs ps1 p q" thus ?thesis by simp qed qed next fix gs bs :: "('t, 'b, 'c) pdata list" and ps hs and data::"nat × 'd" and B and d::"'a ⇒ nat" and m h g assume dg: "dickson_grading d" and B_sup: "set gs ∪ set bs ∪ set hs ⊆ B" and B_sub: "fst ` B ⊆ dgrad_p_set d m" and h_in: "h ∈ set hs" and g_in: "g ∈ set gs ∪ set bs ∪ set hs" and ps_sub: "set ps ⊆ set bs × (set gs ∪ set bs)" and uid: "unique_idx (gs @ bs @ hs) data" and gb: "is_Groebner_basis (fst ` set gs)" and "h ≠ g" and "fst h ≠ 0" and "fst g ≠ 0" assume a: "⋀a b. (a, b) ∈⇩p set (add_pairs gs bs ps hs data) ⟹ fst a ≠ 0 ⟹ fst b ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)" assume b: "⋀a b. a ∈ set gs ∪ set bs ⟹ b ∈ set gs ∪ set bs ⟹ fst a ≠ 0 ⟹ fst b ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)" define ps0 where "ps0 = apply_icrit icrit data gs bs hs (np gs bs hs data)" define ps1 where "ps1 = apply_ncrit ncrit data gs bs hs ps0" have "snd ` snd ` set ps0 = snd ` set (np gs bs hs data)" by (simp add: ps0_def) also from assms(1) have "... ⊆ set hs × (set gs ∪ set bs ∪ set hs)" by (rule np_specD1) finally have ps0_sub: "snd ` snd ` set ps0 ⊆ set hs × (set gs ∪ set bs ∪ set hs)" . have "crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q)" if "(p, q) ∈ snd ` set ps1" and "fst p ≠ 0" and "fst q ≠ 0" for p q proof - from ‹(p, q) ∈ snd ` set ps1› obtain ic where "(ic, p, q) ∈ set ps1" by fastforce show ?thesis proof (cases "ic") case True from ‹(ic, p, q) ∈ set ps1› obtain q_in_bs where "(ic, q_in_bs, p, q) ∈ set ps0" unfolding ps1_def by (rule apply_ncrit_subset) with True have "(True, q_in_bs, p, q) ∈ set ps0" by simp hence "snd (snd (True, q_in_bs, p, q)) ∈ snd ` snd ` set ps0" by fastforce hence "(p, q) ∈ snd ` snd ` set ps0" by simp also have "... ⊆ set hs × (set gs ∪ set bs ∪ set hs)" by (fact ps0_sub) finally have "p ∈ set hs" and "q ∈ set gs ∪ set bs ∪ set hs" by simp_all from B_sup have B_sup': "fst ` (set gs ∪ set bs ∪ set hs) ⊆ fst ` B" by (rule image_mono) hence "fst ` (set gs ∪ set bs ∪ set hs) ⊆ dgrad_p_set d m" using B_sub by (rule subset_trans) from assms(2) dg this uid gb ‹p ∈ set hs› ‹q ∈ set gs ∪ set bs ∪ set hs› ‹fst p ≠ 0› ‹fst q ≠ 0› ‹(True, q_in_bs, p, q) ∈ set ps0› have "crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs ∪ set hs)) (fst p) (fst q)" unfolding ps0_def by (rule fst_apply_icrit) thus ?thesis using B_sup' by (rule crit_pair_cbelow_mono) next case False with ‹(ic, p, q) ∈ set ps1› have "(False, p, q) ∈ set ps1" by simp with assms(5) ps1_def have "(p, q) ∈ set (add_pairs gs bs ps hs data)" by (simp add: set_add_pairs_iff ps0_def) hence "(p, q) ∈⇩p set (add_pairs gs bs ps hs data)" by (simp add: in_pair_iff) thus ?thesis using ‹fst p ≠ 0› ‹fst q ≠ 0› by (rule a) qed qed with assms(3) dg B_sup B_sub ps0_sub uid gb have *: "(ic, q_in_bs, p, q) ∈ set ps0 ⟹ fst p ≠ 0 ⟹ fst q ≠ 0 ⟹ (q_in_bs ⟹ q ∈ set gs ∪ set bs) ⟹ crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q)" for ic q_in_bs p q using b unfolding ps1_def by (rule apply_ncrit_connectible) show "crit_pair_cbelow_on d m (fst ` B) (fst h) (fst g)" proof (cases "h = g") case True from g_in B_sup have "g ∈ B" .. hence "fst g ∈ fst ` B" by simp hence "fst g ∈ dgrad_p_set d m" using B_sub .. with dg show ?thesis unfolding True by (rule crit_pair_cbelow_same) next case False with assms(1) h_in g_in show ?thesis proof (rule np_specE) fix g_in_bs assume "(g_in_bs, h, g) ∈ set (np gs bs hs data)" also have "... = snd ` set ps0" by (simp add: ps0_def) finally obtain ic where "(ic, g_in_bs, h, g) ∈ set ps0" by fastforce moreover note ‹fst h ≠ 0› ‹fst g ≠ 0› moreover from assms(1) have "g ∈ set gs ∪ set bs" if "g_in_bs" proof (rule np_specD4) from ‹(g_in_bs, h, g) ∈ set (np gs bs hs data)› that show "(True, h, g) ∈ set (np gs bs hs data)" by simp qed ultimately show ?thesis by (rule *) next fix h_in_bs assume "(h_in_bs, g, h) ∈ set (np gs bs hs data)" also have "... = snd ` set ps0" by (simp add: ps0_def) finally obtain ic where "(ic, h_in_bs, g, h) ∈ set ps0" by fastforce moreover note ‹fst g ≠ 0› ‹fst h ≠ 0› moreover from assms(1) have "h ∈ set gs ∪ set bs" if "h_in_bs" proof (rule np_specD4) from ‹(h_in_bs, g, h) ∈ set (np gs bs hs data)› that show "(True, g, h) ∈ set (np gs bs hs data)" by simp qed ultimately have "crit_pair_cbelow_on d m (fst ` B) (fst g) (fst h)" by (rule *) thus ?thesis by (rule crit_pair_cbelow_sym) qed qed next fix gs bs :: "('t, 'b, 'c) pdata list" and ps hs and data::"nat × 'd" and B and d::"'a ⇒ nat" and m h g define ps1 where "ps1 = apply_ncrit ncrit data gs bs hs (apply_icrit icrit data gs bs hs (np gs bs hs data))" assume "(h, g) ∈ set ps -⇩p set (add_pairs gs bs ps hs data)" hence "(h, g) ∈ set ps" and "(h, g) ∉⇩p set (add_pairs gs bs ps hs data)" by simp_all from this(2) have "(h, g) ∉ set (add_pairs gs bs ps hs data)" by (simp add: in_pair_iff) assume dg: "dickson_grading d" and B_sup: "set gs ∪ set bs ∪ set hs ⊆ B" and B_sub: "fst ` B ⊆ dgrad_p_set d m" and ps_sub: "set ps ⊆ set bs × (set gs ∪ set bs)" and "(set gs ∪ set bs) ∩ set hs = {}" ― ‹unused› and uid: "unique_idx (gs @ bs @ hs) data" and gb: "is_Groebner_basis (fst ` set gs)" and "h ≠ g" and "fst h ≠ 0" and "fst g ≠ 0" assume *: "⋀a b. (a, b) ∈⇩p set (add_pairs gs bs ps hs data) ⟹ (a, b) ∈⇩p set hs × (set gs ∪ set bs ∪ set hs) ⟹ fst a ≠ 0 ⟹ fst b ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)" have "snd ` set ps1 ⊆ snd ` snd ` set (apply_icrit icrit data gs bs hs (np gs bs hs data))" unfolding ps1_def by (rule apply_ncrit_subset') also have "... = snd ` set (np gs bs hs data)" by simp also from assms(1) have "... ⊆ set hs × (set gs ∪ set bs ∪ set hs)" by (rule np_specD1) finally have ps1_sub: "snd ` set ps1 ⊆ set hs × (set gs ∪ set bs ∪ set hs)" . from ‹(h, g) ∈ set ps› ps_sub have h_in: "h ∈ set gs ∪ set bs" and g_in: "g ∈ set gs ∪ set bs" by fastforce+ with B_sup have "h ∈ B" and "g ∈ B" by auto with assms(4) dg _ B_sub _ _ show "crit_pair_cbelow_on d m (fst ` B) (fst h) (fst g)" using ‹fst h ≠ 0› ‹fst g ≠ 0› ‹(h, g) ∈ set ps› proof (rule apply_ocrit_connectible) from B_sup show "set hs ⊆ B" by simp next from ps1_sub h_in g_in have "set (h # g # hs @ map (fst ∘ snd) ps1 @ map (snd ∘ snd) ps1) ⊆ set (gs @ bs @ hs)" by fastforce with uid show "unique_idx (h # g # hs @ map (fst ∘ snd) ps1 @ map (snd ∘ snd) ps1) data" by (rule unique_idx_subset) next fix p q assume "(p, q) ∈ snd ` set ps1" hence pq_in: "(p, q) ∈ set hs × (set gs ∪ set bs ∪ set hs)" using ps1_sub .. hence p_in: "p ∈ set hs" and q_in: "q ∈ set gs ∪ set bs ∪ set hs" by simp_all assume "fst p ≠ 0" and "fst q ≠ 0" from ‹(p, q) ∈ snd ` set ps1› obtain ic where "(ic, p, q) ∈ set ps1" by fastforce show "crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q)" proof (cases "ic") case True hence "ic = True" by simp from B_sup have B_sup': "fst ` (set gs ∪ set bs ∪ set hs) ⊆ fst ` B" by (rule image_mono) note assms(2) dg moreover from B_sup' B_sub have "fst ` (set gs ∪ set bs ∪ set hs) ⊆ dgrad_p_set d m" by (rule subset_trans) moreover note uid gb p_in q_in ‹fst p ≠ 0› ‹fst q ≠ 0› moreover from ‹(ic, p, q) ∈ set ps1› obtain q_in_bs where "(True, q_in_bs, p, q) ∈ set (apply_icrit icrit data gs bs hs (np gs bs hs data))" unfolding ps1_def ‹ic = True› by (rule apply_ncrit_subset) ultimately have "crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs ∪ set hs)) (fst p) (fst q)" by (rule fst_apply_icrit) thus ?thesis using B_sup' by (rule crit_pair_cbelow_mono) next case False with ‹(ic, p, q) ∈ set ps1› have "(False, p, q) ∈ set ps1" by simp with assms(5) ps1_def have "(p, q) ∈ set (add_pairs gs bs ps hs data)" by (simp add: set_add_pairs_iff) hence "(p, q) ∈⇩p set (add_pairs gs bs ps hs data)" by (simp add: in_pair_iff) moreover from pq_in have "(p, q) ∈⇩p set hs × (set gs ∪ set bs ∪ set hs)" by (simp add: in_pair_iff) ultimately show ?thesis using ‹fst p ≠ 0› ‹fst q ≠ 0› by (rule *) qed next show "(h, g) ∉ set (apply_ocrit ocrit data hs ps1 ps)" proof assume "(h, g) ∈ set (apply_ocrit ocrit data hs ps1 ps)" hence "(h, g) ∈ set (add_pairs gs bs ps hs data)" by (simp add: add_pairs_def assms(5) Let_def ps1_def) with ‹(h, g) ∉ set (add_pairs gs bs ps hs data)› show False .. qed qed qed end abbreviation "add_pairs_canon ≡ add_pairs (new_pairs_sorted canon_pair_order) component_crit chain_ncrit chain_ocrit canon_pair_comb" lemma ap_spec_add_pairs_canon: "ap_spec add_pairs_canon" using np_spec_new_pairs_sorted icrit_spec_component_crit ncrit_spec_chain_ncrit ocrit_spec_chain_ocrit set_merge_wrt by (rule ap_spec_add_pairs) subsection ‹Suitable Instances of the @{emph ‹completion›} Parameter› definition rcp_spec :: "('t, 'b::field, 'c, 'd) complT ⇒ bool" where "rcp_spec rcp ⟷ (∀gs bs ps sps data. 0 ∉ fst ` set (fst (rcp gs bs ps sps data)) ∧ (∀h b. h ∈ set (fst (rcp gs bs ps sps data)) ⟶ b ∈ set gs ∪ set bs ⟶ fst b ≠ 0 ⟶ ¬ lt (fst b) adds⇩t lt (fst h)) ∧ (∀d. dickson_grading d ⟶ dgrad_p_set_le d (fst ` set (fst (rcp gs bs ps sps data))) (args_to_set (gs, bs, sps))) ∧ component_of_term ` Keys (fst ` (set (fst (rcp gs bs ps sps data)))) ⊆ component_of_term ` Keys (args_to_set (gs, bs, sps)) ∧ (is_Groebner_basis (fst ` set gs) ⟶ unique_idx (gs @ bs) data ⟶ (fst ` set (fst (rcp gs bs ps sps data)) ⊆ pmdl (args_to_set (gs, bs, sps)) ∧ (∀(p, q)∈set sps. set sps ⊆ set bs × (set gs ∪ set bs) ⟶ (red (fst ` (set gs ∪ set bs) ∪ fst ` set (fst (rcp gs bs ps sps data))))⇧*⇧* (spoly (fst p) (fst q)) 0))))" text ‹Informally, ‹rcp_spec rcp› expresses that, for suitable ‹gs›, ‹bs› and ‹sps›, the value of ‹rcp gs bs ps sps› \begin{itemize} \item is a list consisting exclusively of non-zero polynomials contained in the module generated by ‹set bs ∪ set gs›, whose leading terms are not divisible by the leading term of any non-zero @{prop "b ∈ set bs"}, and \item contains sufficiently many new polynomials such that all S-polynomials originating from ‹sps› can be reduced to ‹0› modulo the enlarged list of polynomials. \end{itemize}› lemma rcp_specI: assumes "⋀gs bs ps sps data. 0 ∉ fst ` set (fst (rcp gs bs ps sps data))" assumes "⋀gs bs ps sps h b data. h ∈ set (fst (rcp gs bs ps sps data)) ⟹ b ∈ set gs ∪ set bs ⟹ fst b ≠ 0 ⟹ ¬ lt (fst b) adds⇩t lt (fst h)" assumes "⋀gs bs ps sps d data. dickson_grading d ⟹ dgrad_p_set_le d (fst ` set (fst (rcp gs bs ps sps data))) (args_to_set (gs, bs, sps))" assumes "⋀gs bs ps sps data. component_of_term ` Keys (fst ` (set (fst (rcp gs bs ps sps data)))) ⊆ component_of_term ` Keys (args_to_set (gs, bs, sps))" assumes "⋀gs bs ps sps data. is_Groebner_basis (fst ` set gs) ⟹ unique_idx (gs @ bs) data ⟹ (fst ` set (fst (rcp gs bs ps sps data)) ⊆ pmdl (args_to_set (gs, bs, sps)) ∧ (∀(p, q)∈set sps. set sps ⊆ set bs × (set gs ∪ set bs) ⟶ (red (fst ` (set gs ∪ set bs) ∪ fst ` set (fst (rcp gs bs ps sps data))))⇧*⇧* (spoly (fst p) (fst q)) 0))" shows "rcp_spec rcp" unfolding rcp_spec_def using assms by auto lemma rcp_specD1: assumes "rcp_spec rcp" shows "0 ∉ fst ` set (fst (rcp gs bs ps sps data))" using assms unfolding rcp_spec_def by (elim allE conjE) lemma rcp_specD2: assumes "rcp_spec rcp" and "h ∈ set (fst (rcp gs bs ps sps data))" and "b ∈ set gs ∪ set bs" and "fst b ≠ 0" shows "¬ lt (fst b) adds⇩t lt (fst h)" using assms unfolding rcp_spec_def by (elim allE conjE, blast) lemma rcp_specD3: assumes "rcp_spec rcp" and "dickson_grading d" shows "dgrad_p_set_le d (fst ` set (fst (rcp gs bs ps sps data))) (args_to_set (gs, bs, sps))" using assms unfolding rcp_spec_def by (elim allE conjE, blast) lemma rcp_specD4: assumes "rcp_spec rcp" shows "component_of_term ` Keys (fst ` (set (fst (rcp gs bs ps sps data)))) ⊆ component_of_term ` Keys (args_to_set (gs, bs, sps))" using assms unfolding rcp_spec_def by (elim allE conjE) lemma rcp_specD5: assumes "rcp_spec rcp" and "is_Groebner_basis (fst ` set gs)" and "unique_idx (gs @ bs) data" shows "fst ` set (fst (rcp gs bs ps sps data)) ⊆ pmdl (args_to_set (gs, bs, sps))" using assms unfolding rcp_spec_def by blast lemma rcp_specD6: assumes "rcp_spec rcp" and "is_Groebner_basis (fst ` set gs)" and "unique_idx (gs @ bs) data" and "set sps ⊆ set bs × (set gs ∪ set bs)" and "(p, q) ∈ set sps" shows "(red (fst ` (set gs ∪ set bs) ∪ fst ` set (fst (rcp gs bs ps sps data))))⇧*⇧* (spoly (fst p) (fst q)) 0" using assms unfolding rcp_spec_def by blast lemma compl_struct_rcp: assumes "rcp_spec rcp" shows "compl_struct rcp" proof (rule compl_structI) fix d::"'a ⇒ nat" and gs bs ps and sps::"('t, 'b, 'c) pdata_pair list" and data::"nat × 'd" assume "dickson_grading d" and "set sps ⊆ set ps" from assms this(1) have "dgrad_p_set_le d (fst ` set (fst (rcp gs bs (ps -- sps) sps data))) (args_to_set (gs, bs, sps))" by (rule rcp_specD3) also have "dgrad_p_set_le d ... (args_to_set (gs, bs, ps))" by (rule dgrad_p_set_le_subset, rule args_to_set_subset3, fact ‹set sps ⊆ set ps›) finally show "dgrad_p_set_le d (fst ` set (fst (rcp gs bs (ps -- sps) sps data))) (args_to_set (gs, bs, ps))" . next fix gs bs ps and sps::"('t, 'b, 'c) pdata_pair list" and data::"nat × 'd" from assms show "0 ∉ fst ` set (fst (rcp gs bs (ps -- sps) sps data))" by (rule rcp_specD1) next fix gs bs ps sps h b data assume "h ∈ set (fst (rcp gs bs (ps -- sps) sps data))" and "b ∈ set gs ∪ set bs" and "fst b ≠ 0" with assms show "¬ lt (fst b) adds⇩t lt (fst h)" by (rule rcp_specD2) next fix gs bs ps and sps::"('t, 'b, 'c) pdata_pair list" and data::"nat × 'd" assume "set sps ⊆ set ps" from assms have "component_of_term ` Keys (fst ` set (fst (rcp gs bs (ps -- sps) sps data))) ⊆ component_of_term ` Keys (args_to_set (gs, bs, sps))" by (rule rcp_specD4) also have "... ⊆ component_of_term ` Keys (args_to_set (gs, bs, ps))" by (rule image_mono, rule Keys_mono, rule args_to_set_subset3, fact ‹set sps ⊆ set ps›) finally show "component_of_term ` Keys (fst ` set (fst (rcp gs bs (ps -- sps) sps data))) ⊆ component_of_term ` Keys (args_to_set (gs, bs, ps))" . qed lemma compl_pmdl_rcp: assumes "rcp_spec rcp" shows "compl_pmdl rcp" proof (rule compl_pmdlI) fix gs bs :: "('t, 'b, 'c) pdata list" and ps sps :: "('t, 'b, 'c) pdata_pair list" and data::"nat × 'd" assume gb: "is_Groebner_basis (fst ` set gs)" and "set sps ⊆ set ps" and un: "unique_idx (gs @ bs) data" let ?res = "fst (rcp gs bs (ps -- sps) sps data)" from assms gb un have "fst ` set ?res ⊆ pmdl (args_to_set (gs, bs, sps))" by (rule rcp_specD5) also have "... ⊆ pmdl (args_to_set (gs, bs, ps))" by (rule pmdl.span_mono, rule args_to_set_subset3, fact ‹set sps ⊆ set ps›) finally show "fst ` set ?res ⊆ pmdl (args_to_set (gs, bs, ps))" . qed lemma compl_conn_rcp: assumes "rcp_spec rcp" shows "compl_conn rcp" proof (rule compl_connI) fix d::"'a ⇒ nat" and m gs bs ps sps p and q::"('t, 'b, 'c) pdata" and data::"nat × 'd" assume dg: "dickson_grading d" and gs_sub: "fst ` set gs ⊆ dgrad_p_set d m" and gb: "is_Groebner_basis (fst ` set gs)" and bs_sub: "fst ` set bs ⊆ dgrad_p_set d m" and ps_sub: "set ps ⊆ set bs × (set gs ∪ set bs)" and "set sps ⊆ set ps" and uid: "unique_idx (gs @ bs) data" and "(p, q) ∈ set sps" and "fst p ≠ 0" and "fst q ≠ 0" from ‹set sps ⊆ set ps› ps_sub have sps_sub: "set sps ⊆ set bs × (set gs ∪ set bs)" by (rule subset_trans) let ?res = "fst (rcp gs bs (ps -- sps) sps data)" have "fst ` set ?res ⊆ dgrad_p_set d m" proof (rule dgrad_p_set_le_dgrad_p_set, rule rcp_specD3, fact+) show "args_to_set (gs, bs, sps) ⊆ dgrad_p_set d m" by (simp add: args_to_set_subset_Times[OF sps_sub], rule, fact+) qed moreover have gs_bs_sub: "fst ` (set gs ∪ set bs) ⊆ dgrad_p_set d m" by (simp add: image_Un, rule, fact+) ultimately have res_sub: "fst ` (set gs ∪ set bs) ∪ fst ` set ?res ⊆ dgrad_p_set d m" by simp from ‹(p, q) ∈ set sps› ‹set sps ⊆ set ps› ps_sub have "fst p ∈ fst ` set bs" and "fst q ∈ fst ` (set gs ∪ set bs)" by auto with ‹fst ` set bs ⊆ dgrad_p_set d m› gs_bs_sub have "fst p ∈ dgrad_p_set d m" and "fst q ∈ dgrad_p_set d m" by auto with dg res_sub show "crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs) ∪ fst ` set ?res) (fst p) (fst q)" using ‹fst p ≠ 0› ‹fst q ≠ 0› proof (rule spoly_red_zero_imp_crit_pair_cbelow_on) from assms gb uid sps_sub ‹(p, q) ∈ set sps› show "(red (fst ` (set gs ∪ set bs) ∪ fst ` set (fst (rcp gs bs (ps -- sps) sps data))))⇧*⇧* (spoly (fst p) (fst q)) 0" by (rule rcp_specD6) qed qed end (* gd_term *) subsection ‹Suitable Instances of the @{emph ‹add-basis›} Parameter› definition add_basis_naive :: "('a, 'b, 'c, 'd) abT" where "add_basis_naive gs bs ns data = bs @ ns" lemma ab_spec_add_basis_naive: "ab_spec add_basis_naive" by (rule ab_specI, simp_all add: add_basis_naive_def) definition add_basis_sorted :: "(nat × 'd ⇒ ('a, 'b, 'c) pdata ⇒ ('a, 'b, 'c) pdata ⇒ bool) ⇒ ('a, 'b, 'c, 'd) abT" where "add_basis_sorted rel gs bs ns data = merge_wrt (rel data) bs ns" lemma ab_spec_add_basis_sorted: "ab_spec (add_basis_sorted rel)" by (rule ab_specI, simp_all add: add_basis_sorted_def set_merge_wrt) definition card_keys :: "('a ⇒⇩0 'b::zero) ⇒ nat" where "card_keys = card ∘ keys" definition (in ordered_term) canon_basis_order :: "'d ⇒ ('t, 'b::zero, 'c) pdata ⇒ ('t, 'b, 'c) pdata ⇒ bool" where "canon_basis_order data p q ⟷ (let cp = card_keys (fst p); cq = card_keys (fst q) in cp < cq ∨ (cp = cq ∧ lt (fst p) ≺⇩t lt (fst q)))" abbreviation (in ordered_term) "add_basis_canon ≡ add_basis_sorted canon_basis_order" subsection ‹Special Case: Scalar Polynomials› context gd_powerprod begin lemma remdups_map_component_of_term_punit: "remdups (map (λ_. ()) (punit.Keys_to_list (map fst bs))) = (if (∀b∈set bs. fst b = 0) then [] else [()])" proof (split if_split, intro conjI impI) assume "∀b∈set bs. fst b = 0" hence "fst ` set bs ⊆ {0}" by blast hence "Keys (fst ` set bs) = {}" by (metis Keys_empty Keys_zero subset_singleton_iff) hence "punit.Keys_to_list (map fst bs) = []" by (simp add: set_empty[symmetric] punit.set_Keys_to_list del: set_empty) thus "remdups (map (λ_. ()) (punit.Keys_to_list (map fst bs))) = []" by simp next assume "¬ (∀b∈set bs. fst b = 0)" hence "∃b∈set bs. fst b ≠ 0" by simp then obtain b where "b ∈ set bs" and "fst b ≠ 0" .. hence "Keys (fst ` set bs) ≠ {}" by (meson Keys_not_empty ‹fst b ≠ 0› imageI) hence "set (punit.Keys_to_list (map fst bs)) ≠ {}" by (simp add: punit.set_Keys_to_list) hence "punit.Keys_to_list (map fst bs) ≠ []" by simp thus "remdups (map (λ_. ()) (punit.Keys_to_list (map fst bs))) = [()]" by (metis (full_types) old.unit.exhaust sorted.cases Nil_is_map_conv ‹punit.Keys_to_list (map fst bs) ≠ []› distinct_length_2_or_more distinct_remdups remdups_eq_nil_right_iff) (*SLOW: 13s*) qed lemma count_const_lt_components_punit [code]: "punit.count_const_lt_components hs = (if (∃h∈set hs. punit.const_lt_component (fst h) = Some ()) then 1 else 0)" proof (simp add: punit.count_const_lt_components_def cong del: image_cong_simp, simp add: card_set [symmetric] cong del: image_cong_simp, rule) assume "∃h∈set hs. punit.const_lt_component (fst h) = Some ()" then obtain h where "h ∈ set hs" and "punit.const_lt_component (fst h) = Some ()" .. from this(2) have "(punit.const_lt_component ∘ fst) h = Some ()" by simp with ‹h ∈ set hs› have "Some () ∈ (punit.const_lt_component ∘ fst) ` set hs" by (metis rev_image_eqI) hence "{x. x = Some () ∧ x ∈ (punit.const_lt_component ∘ fst) ` set hs} = {Some ()}" by auto thus "card {x. x = Some () ∧ x ∈ (punit.const_lt_component ∘ fst) ` set hs} = Suc 0" by simp qed lemma count_rem_components_punit [code]: "punit.count_rem_components bs = (if (∀b∈set bs. fst b = 0) then 0 else if (∃b∈set bs. fst b ≠ 0 ∧ punit.const_lt_component (fst b) = Some ()) then 0 else 1)" proof (cases "∀b∈set bs. fst b = 0") case True thus ?thesis by (simp add: punit.count_rem_components_def remdups_map_component_of_term_punit) next case False have eq: "(∃b∈set [b←bs . fst b ≠ 0]. punit.const_lt_component (fst b) = Some ()) = (∃b∈set bs. fst b ≠ 0 ∧ punit.const_lt_component (fst b) = Some ())" by (metis (mono_tags, lifting) filter_set member_filter) show ?thesis by (simp only: False punit.count_rem_components_def eq if_False remdups_map_component_of_term_punit count_const_lt_components_punit punit_component_of_term, simp) qed lemma full_gb_punit [code]: "punit.full_gb bs = (if (∀b∈set bs. fst b = 0) then [] else [(1, 0, default)])" by (simp add: punit.full_gb_def remdups_map_component_of_term_punit) abbreviation "add_pairs_punit_canon ≡ punit.add_pairs (punit.new_pairs_sorted punit.canon_pair_order) punit.product_crit punit.chain_ncrit punit.chain_ocrit punit.canon_pair_comb" lemma ap_spec_add_pairs_punit_canon: "punit.ap_spec add_pairs_punit_canon" using punit.np_spec_new_pairs_sorted punit.icrit_spec_product_crit punit.ncrit_spec_chain_ncrit punit.ocrit_spec_chain_ocrit set_merge_wrt by (rule punit.ap_spec_add_pairs) end (* gd_powerprod *) end (* theory *)
Theory Buchberger
(* Author: Alexander Maletzky *) section ‹Buchberger's Algorithm› theory Buchberger imports Algorithm_Schema begin context gd_term begin subsection ‹Reduction› definition trdsp::"('t ⇒⇩0 'b) list ⇒ ('t, 'b, 'c) pdata_pair ⇒ ('t ⇒⇩0 'b::field)" where "trdsp bs p ≡ trd bs (spoly (fst (fst p)) (fst (snd p)))" lemma trdsp_alt: "trdsp bs (p, q) = trd bs (spoly (fst p) (fst q))" by (simp add: trdsp_def) lemma trdsp_in_pmdl: "trdsp bs (p, q) ∈ pmdl (insert (fst p) (insert (fst q) (set bs)))" unfolding trdsp_alt proof (rule pmdl_closed_trd) have "spoly (fst p) (fst q) ∈ pmdl {fst p, fst q}" proof (rule pmdl_closed_spoly) show "fst p ∈ pmdl {fst p, fst q}" by (rule pmdl.span_base, simp) next show "fst q ∈ pmdl {fst p, fst q}" by (rule pmdl.span_base, simp) qed also have "... ⊆ pmdl (insert (fst p) (insert (fst q) (set bs)))" by (rule pmdl.span_mono, simp) finally show "spoly (fst p) (fst q) ∈ pmdl (insert (fst p) (insert (fst q) (set bs)))" . next have "set bs ⊆ insert (fst p) (insert (fst q) (set bs))" by blast also have "... ⊆ pmdl (insert (fst p) (insert (fst q) (set bs)))" by (fact pmdl.span_superset) finally show "set bs ⊆ pmdl (insert (fst p) (insert (fst q) (set bs)))" . qed lemma dgrad_p_set_le_trdsp: assumes "dickson_grading d" shows "dgrad_p_set_le d {trdsp bs (p, q)} (insert (fst p) (insert (fst q) (set bs)))" proof - let ?h = "trdsp bs (p, q)" have "(red (set bs))⇧*⇧* (spoly (fst p) (fst q)) ?h" unfolding trdsp_alt by (rule trd_red_rtrancl) with assms have "dgrad_p_set_le d {?h} (insert (spoly (fst p) (fst q)) (set bs))" by (rule dgrad_p_set_le_red_rtrancl) also have "dgrad_p_set_le d ... ({fst p, fst q} ∪ set bs)" proof (rule dgrad_p_set_leI_insert) show "dgrad_p_set_le d (set bs) ({fst p, fst q} ∪ set bs)" by (rule dgrad_p_set_le_subset, blast) next from assms have "dgrad_p_set_le d {spoly (fst p) (fst q)} {fst p, fst q}" by (rule dgrad_p_set_le_spoly) also have "dgrad_p_set_le d ... ({fst p, fst q} ∪ set bs)" by (rule dgrad_p_set_le_subset, blast) finally show "dgrad_p_set_le d {spoly (fst p) (fst q)} ({fst p, fst q} ∪ set bs)" . qed finally show ?thesis by simp qed lemma components_trdsp_subset: "component_of_term ` keys (trdsp bs (p, q)) ⊆ component_of_term ` Keys (insert (fst p) (insert (fst q) (set bs)))" proof - let ?h = "trdsp bs (p, q)" have "(red (set bs))⇧*⇧* (spoly (fst p) (fst q)) ?h" unfolding trdsp_alt by (rule trd_red_rtrancl) hence "component_of_term ` keys ?h ⊆ component_of_term ` keys (spoly (fst p) (fst q)) ∪ component_of_term ` Keys (set bs)" by (rule components_red_rtrancl_subset) also have "... ⊆ component_of_term ` Keys {fst p, fst q} ∪ component_of_term ` Keys (set bs)" using components_spoly_subset by force also have "... = component_of_term ` Keys (insert (fst p) (insert (fst q) (set bs)))" by (simp add: Keys_insert image_Un Un_assoc) finally show ?thesis . qed definition gb_red_aux :: "('t, 'b::field, 'c) pdata list ⇒ ('t, 'b, 'c) pdata_pair list ⇒ ('t ⇒⇩0 'b) list" where "gb_red_aux bs ps = (let bs' = map fst bs in filter (λh. h ≠ 0) (map (trdsp bs') ps) )" text ‹Actually, @{const gb_red_aux} is only called on singleton lists.› lemma set_gb_red_aux: "set (gb_red_aux bs ps) = (trdsp (map fst bs)) ` set ps - {0}" by (simp add: gb_red_aux_def, blast) lemma in_set_gb_red_auxI: assumes "(p, q) ∈ set ps" and "h = trdsp (map fst bs) (p, q)" and "h ≠ 0" shows "h ∈ set (gb_red_aux bs ps)" using assms(1, 3) unfolding set_gb_red_aux assms(2) by force lemma in_set_gb_red_auxE: assumes "h ∈ set (gb_red_aux bs ps)" obtains p q where "(p, q) ∈ set ps" and "h = trdsp (map fst bs) (p, q)" using assms unfolding set_gb_red_aux by force lemma gb_red_aux_not_zero: "0 ∉ set (gb_red_aux bs ps)" by (simp add: set_gb_red_aux) lemma gb_red_aux_irredudible: assumes "h ∈ set (gb_red_aux bs ps)" and "b ∈ set bs" and "fst b ≠ 0" shows "¬ lt (fst b) adds⇩t lt h" proof assume "lt (fst b) adds⇩t (lt h)" from assms(1) obtain p q :: "('t, 'b, 'c) pdata" where h: "h = trdsp (map fst bs) (p, q)" by (rule in_set_gb_red_auxE) have "¬ is_red (set (map fst bs)) h" unfolding h trdsp_def by (rule trd_irred) moreover have "is_red (set (map fst bs)) h" proof (rule is_red_addsI) from assms(2) show "fst b ∈ set (map fst bs)" by (simp) next from assms(1) have "h ≠ 0" by (simp add: set_gb_red_aux) thus "lt h ∈ keys h" by (rule lt_in_keys) qed fact+ ultimately show False .. qed lemma gb_red_aux_dgrad_p_set_le: assumes "dickson_grading d" shows "dgrad_p_set_le d (set (gb_red_aux bs ps)) (args_to_set ([], bs, ps))" proof (rule dgrad_p_set_leI) fix h assume "h ∈ set (gb_red_aux bs ps)" then obtain p q where "(p, q) ∈ set ps" and h: "h = trdsp (map fst bs) (p, q)" by (rule in_set_gb_red_auxE) from assms have "dgrad_p_set_le d {h} (insert (fst p) (insert (fst q) (set (map fst bs))))" unfolding h by (rule dgrad_p_set_le_trdsp) also have "dgrad_p_set_le d ... (args_to_set ([], bs, ps))" proof (rule dgrad_p_set_le_subset, intro insert_subsetI) from ‹(p, q) ∈ set ps› have "fst p ∈ fst ` fst ` set ps" by force thus "fst p ∈ args_to_set ([], bs, ps)" by (auto simp add: args_to_set_alt) next from ‹(p, q) ∈ set ps› have "fst q ∈ fst ` snd ` set ps" by force thus "fst q ∈ args_to_set ([], bs, ps)" by (auto simp add: args_to_set_alt) next show "set (map fst bs) ⊆ args_to_set ([], bs, ps)" by (auto simp add: args_to_set_alt) qed finally show "dgrad_p_set_le d {h} (args_to_set ([], bs, ps))" . qed lemma components_gb_red_aux_subset: "component_of_term ` Keys (set (gb_red_aux bs ps)) ⊆ component_of_term ` Keys (args_to_set ([], bs, ps))" proof fix k assume "k ∈ component_of_term ` Keys (set (gb_red_aux bs ps))" then obtain v where "v ∈ Keys (set (gb_red_aux bs ps))" and k: "k = component_of_term v" .. from this(1) obtain h where "h ∈ set (gb_red_aux bs ps)" and "v ∈ keys h" by (rule in_KeysE) from this(1) obtain p q where "(p, q) ∈ set ps" and h: "h = trdsp (map fst bs) (p, q)" by (rule in_set_gb_red_auxE) from ‹v ∈ keys h› have "k ∈ component_of_term ` keys h" by (simp add: k) have "component_of_term ` keys h ⊆ component_of_term ` Keys (insert (fst p) (insert (fst q) (set (map fst bs))))" unfolding h by (rule components_trdsp_subset) also have "... ⊆ component_of_term ` Keys (args_to_set ([], bs, ps))" proof (rule image_mono, rule Keys_mono, intro insert_subsetI) from ‹(p, q) ∈ set ps› have "fst p ∈ fst ` fst ` set ps" by force thus "fst p ∈ args_to_set ([], bs, ps)" by (auto simp add: args_to_set_alt) next from ‹(p, q) ∈ set ps› have "fst q ∈ fst ` snd ` set ps" by force thus "fst q ∈ args_to_set ([], bs, ps)" by (auto simp add: args_to_set_alt) next show "set (map fst bs) ⊆ args_to_set ([], bs, ps)" by (auto simp add: args_to_set_alt) qed finally have "component_of_term ` keys h ⊆ component_of_term ` Keys (args_to_set ([], bs, ps))" . with ‹k ∈ component_of_term ` keys h› show "k ∈ component_of_term ` Keys (args_to_set ([], bs, ps))" .. qed lemma pmdl_gb_red_aux: "set (gb_red_aux bs ps) ⊆ pmdl (args_to_set ([], bs, ps))" proof fix h assume "h ∈ set (gb_red_aux bs ps)" then obtain p q where "(p, q) ∈ set ps" and h: "h = trdsp (map fst bs) (p, q)" by (rule in_set_gb_red_auxE) have "h ∈ pmdl (insert (fst p) (insert (fst q) (set (map fst bs))))" unfolding h by (fact trdsp_in_pmdl) also have "... ⊆ pmdl (args_to_set ([], bs, ps))" proof (rule pmdl.span_mono, intro insert_subsetI) from ‹(p, q) ∈ set ps› have "fst p ∈ fst ` fst ` set ps" by force thus "fst p ∈ args_to_set ([], bs, ps)" by (auto simp add: args_to_set_alt) next from ‹(p, q) ∈ set ps› have "fst q ∈ fst ` snd ` set ps" by force thus "fst q ∈ args_to_set ([], bs, ps)" by (auto simp add: args_to_set_alt) next show "set (map fst bs) ⊆ args_to_set ([], bs, ps)" by (auto simp add: args_to_set_alt) qed finally show "h ∈ pmdl (args_to_set ([], bs, ps))" . qed lemma gb_red_aux_spoly_reducible: assumes "(p, q) ∈ set ps" shows "(red (fst ` set bs ∪ set (gb_red_aux bs ps)))⇧*⇧* (spoly (fst p) (fst q)) 0" proof - define h where "h = trdsp (map fst bs) (p, q)" from trd_red_rtrancl[of "map fst bs" "spoly (fst p) (fst q)"] have "(red (set (map fst bs)))⇧*⇧* (spoly (fst p) (fst q)) h" by (simp only: h_def trdsp_alt) hence "(red (fst ` set bs ∪ set (gb_red_aux bs ps)))⇧*⇧* (spoly (fst p) (fst q)) h" proof (rule red_rtrancl_subset) show "set (map fst bs) ⊆ fst ` set bs ∪ set (gb_red_aux bs ps)" by simp qed moreover have "(red (fst ` set bs ∪ set (gb_red_aux bs ps)))⇧*⇧* h 0" proof (cases "h = 0") case True show ?thesis unfolding True .. next case False hence "red {h} h 0" by (rule red_self) hence "red (fst ` set bs ∪ set (gb_red_aux bs ps)) h 0" proof (rule red_subset) from assms h_def False have "h ∈ set (gb_red_aux bs ps)" by (rule in_set_gb_red_auxI) thus "{h} ⊆ fst ` set bs ∪ set (gb_red_aux bs ps)" by simp qed thus ?thesis .. qed ultimately show ?thesis by simp qed definition gb_red :: "('t, 'b::field, 'c::default, 'd) complT" where "gb_red gs bs ps sps data = (map (λh. (h, default)) (gb_red_aux (gs @ bs) sps), snd data)" lemma fst_set_fst_gb_red: "fst ` set (fst (gb_red gs bs ps sps data)) = set (gb_red_aux (gs @ bs) sps)" by (simp add: gb_red_def, force) lemma rcp_spec_gb_red: "rcp_spec gb_red" proof (rule rcp_specI) fix gs bs::"('t, 'b, 'c) pdata list" and ps sps and data::"nat × 'd" from gb_red_aux_not_zero show "0 ∉ fst ` set (fst (gb_red gs bs ps sps data))" unfolding fst_set_fst_gb_red . next fix gs bs::"('t, 'b, 'c) pdata list" and ps sps h b and data::"nat × 'd" assume "h ∈ set (fst (gb_red gs bs ps sps data))" and "b ∈ set gs ∪ set bs" from this(1) have "fst h ∈ fst ` set (fst (gb_red gs bs ps sps data))" by simp hence "fst h ∈ set (gb_red_aux (gs @ bs) sps)" by (simp only: fst_set_fst_gb_red) moreover from ‹b ∈ set gs ∪ set bs› have "b ∈ set (gs @ bs)" by simp moreover assume "fst b ≠ 0" ultimately show "¬ lt (fst b) adds⇩t lt (fst h)" by (rule gb_red_aux_irredudible) next fix gs bs::"('t, 'b, 'c) pdata list" and ps sps and d::"'a ⇒ nat" and data::"nat × 'd" assume "dickson_grading d" hence "dgrad_p_set_le d (set (gb_red_aux (gs @ bs) sps)) (args_to_set ([], gs @ bs, sps))" by (rule gb_red_aux_dgrad_p_set_le) also have "... = args_to_set (gs, bs, sps)" by (simp add: args_to_set_alt image_Un) finally show "dgrad_p_set_le d (fst ` set (fst (gb_red gs bs ps sps data))) (args_to_set (gs, bs, sps))" by (simp only: fst_set_fst_gb_red) next fix gs bs::"('t, 'b, 'c) pdata list" and ps sps and data::"nat × 'd" have "component_of_term ` Keys (set (gb_red_aux (gs @ bs) sps)) ⊆ component_of_term ` Keys (args_to_set ([], gs @ bs, sps))" by (rule components_gb_red_aux_subset) also have "... = component_of_term ` Keys (args_to_set (gs, bs, sps))" by (simp add: args_to_set_alt image_Un) finally show "component_of_term ` Keys (fst ` set (fst (gb_red gs bs ps sps data))) ⊆ component_of_term ` Keys (args_to_set (gs, bs, sps))" by (simp only: fst_set_fst_gb_red) next fix gs bs::"('t, 'b, 'c) pdata list" and ps sps and data::"nat × 'd" have "set (gb_red_aux (gs @ bs) sps) ⊆ pmdl (args_to_set ([], gs @ bs, sps))" by (fact pmdl_gb_red_aux) also have "... = pmdl (args_to_set (gs, bs, sps))" by (simp add: args_to_set_alt image_Un) finally have "fst ` set (fst (gb_red gs bs ps sps data)) ⊆ pmdl (args_to_set (gs, bs, sps))" by (simp only: fst_set_fst_gb_red) moreover { fix p q :: "('t, 'b, 'c) pdata" assume "(p, q) ∈ set sps" hence "(red (fst ` set (gs @ bs) ∪ set (gb_red_aux (gs @ bs) sps)))⇧*⇧* (spoly (fst p) (fst q)) 0" by (rule gb_red_aux_spoly_reducible) } ultimately show "fst ` set (fst (gb_red gs bs ps sps data)) ⊆ pmdl (args_to_set (gs, bs, sps)) ∧ (∀(p, q)∈set sps. set sps ⊆ set bs × (set gs ∪ set bs) ⟶ (red (fst ` (set gs ∪ set bs) ∪ fst ` set (fst (gb_red gs bs ps sps data))))⇧*⇧* (spoly (fst p) (fst q)) 0)" by (auto simp add: image_Un fst_set_fst_gb_red) qed lemmas compl_struct_gb_red = compl_struct_rcp[OF rcp_spec_gb_red] lemmas compl_pmdl_gb_red = compl_pmdl_rcp[OF rcp_spec_gb_red] lemmas compl_conn_gb_red = compl_conn_rcp[OF rcp_spec_gb_red] subsection ‹Pair Selection› primrec gb_sel :: "('t, 'b::zero, 'c, 'd) selT" where "gb_sel gs bs [] data = []"| "gb_sel gs bs (p # ps) data = [p]" lemma sel_spec_gb_sel: "sel_spec gb_sel" proof (rule sel_specI) fix gs bs :: "('t, 'b, 'c) pdata list" and ps::"('t, 'b, 'c) pdata_pair list" and data::"nat × 'd" assume "ps ≠ []" then obtain p ps' where ps: "ps = p # ps'" by (meson list.exhaust) show "gb_sel gs bs ps data ≠ [] ∧ set (gb_sel gs bs ps data) ⊆ set ps" by (simp add: ps) qed subsection ‹Buchberger's Algorithm› lemma struct_spec_gb: "struct_spec gb_sel add_pairs_canon add_basis_canon gb_red" using sel_spec_gb_sel ap_spec_add_pairs_canon ab_spec_add_basis_sorted compl_struct_gb_red by (rule struct_specI) definition gb_aux :: "('t, 'b, 'c) pdata list ⇒ nat × nat × 'd ⇒ ('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata_pair list ⇒ ('t, 'b::field, 'c::default) pdata list" where "gb_aux = gb_schema_aux gb_sel add_pairs_canon add_basis_canon gb_red" lemmas gb_aux_simps [code] = gb_schema_aux_simps[OF struct_spec_gb, folded gb_aux_def] definition gb :: "('t, 'b, 'c) pdata' list ⇒ 'd ⇒ ('t, 'b::field, 'c::default) pdata' list" where "gb = gb_schema_direct gb_sel add_pairs_canon add_basis_canon gb_red" lemmas gb_simps [code] = gb_schema_direct_def[of gb_sel add_pairs_canon add_basis_canon gb_red, folded gb_def gb_aux_def] lemmas gb_isGB = gb_schema_direct_isGB[OF struct_spec_gb compl_conn_gb_red, folded gb_def] lemmas gb_pmdl = gb_schema_direct_pmdl[OF struct_spec_gb compl_pmdl_gb_red, folded gb_def] subsubsection ‹Special Case: ‹punit›› lemma (in gd_term) struct_spec_gb_punit: "punit.struct_spec punit.gb_sel add_pairs_punit_canon punit.add_basis_canon punit.gb_red" using punit.sel_spec_gb_sel ap_spec_add_pairs_punit_canon ab_spec_add_basis_sorted punit.compl_struct_gb_red by (rule punit.struct_specI) definition gb_aux_punit :: "('a, 'b, 'c) pdata list ⇒ nat × nat × 'd ⇒ ('a, 'b, 'c) pdata list ⇒ ('a, 'b, 'c) pdata_pair list ⇒ ('a, 'b::field, 'c::default) pdata list" where "gb_aux_punit = punit.gb_schema_aux punit.gb_sel add_pairs_punit_canon punit.add_basis_canon punit.gb_red" lemmas gb_aux_punit_simps [code] = punit.gb_schema_aux_simps[OF struct_spec_gb_punit, folded gb_aux_punit_def] definition gb_punit :: "('a, 'b, 'c) pdata' list ⇒ 'd ⇒ ('a, 'b::field, 'c::default) pdata' list" where "gb_punit = punit.gb_schema_direct punit.gb_sel add_pairs_punit_canon punit.add_basis_canon punit.gb_red" lemmas gb_punit_simps [code] = punit.gb_schema_direct_def[of "punit.gb_sel" add_pairs_punit_canon "punit.add_basis_canon" "punit.gb_red", folded gb_punit_def gb_aux_punit_def] lemmas gb_punit_isGB = punit.gb_schema_direct_isGB[OF struct_spec_gb_punit punit.compl_conn_gb_red, folded gb_punit_def] lemmas gb_punit_pmdl = punit.gb_schema_direct_pmdl[OF struct_spec_gb_punit punit.compl_pmdl_gb_red, folded gb_punit_def] end (* gd_term *) end (* theory *)
Theory Benchmarks
(* Author: Alexander Maletzky *) section ‹Benchmark Problems for Computing Gr\"obner Bases› theory Benchmarks imports Polynomials.MPoly_Type_Class_OAlist begin text ‹This theory defines various well-known benchmark problems for computing Gr\"obner bases. The actual tests of the different algorithms on these problems are contained in the theories whose names end with ‹_Examples›.› subsection ‹Cyclic› definition cycl_pp :: "nat ⇒ nat ⇒ nat ⇒ (nat, nat) pp" where "cycl_pp n d i = sparse⇩0 (map (λk. (modulo (k + i) n, 1)) [0..<d])" definition cyclic :: "(nat, nat) pp nat_term_order ⇒ nat ⇒ ((nat, nat) pp ⇒⇩0 'a::{zero,one,uminus}) list" where "cyclic to n = (let xs = [0..<n] in (map (λd. distr⇩0 to (map (λi. (cycl_pp n d i, 1)) xs)) [1..<n]) @ [distr⇩0 to [(cycl_pp n n 0, 1), (0, -1)]] )" text ‹@{term "cyclic n"} is a system of ‹n› polynomials in ‹n› indeterminates, with maximum degree ‹n›.› (* Input: n Define: m ≡ n - 1 Variables: x(0), ..., x(m) Polynomials: p(0), ..., p(m) p(0) = x(0) + ... + x(m) p(1) = x(0)*x(1) + x(1)*x(2) + ... + x(m-1)*x(m) + x(m)*x(0) p(1) = x(0)*x(1)*x(2) + x(1)*x(2)*x(3) + ... + x(m-1)*x(m)*x(0) + x(m)*x(0)*x(1) ... p(m) = x(0)*x(1)*...*x(m) - 1 *) subsection ‹Katsura› definition katsura_poly :: "(nat, nat) pp nat_term_order ⇒ nat ⇒ nat ⇒ ((nat, nat) pp ⇒⇩0 'a::comm_ring_1)" where "katsura_poly to n i = change_ord to ((∑j::int=-int n..<n + 1. if abs (i - j) ≤ n then V⇩0 (nat (abs j)) * V⇩0 (nat (abs (i - j))) else 0) - V⇩0 i)" definition katsura :: "(nat, nat) pp nat_term_order ⇒ nat ⇒ ((nat, nat) pp ⇒⇩0 'a::comm_ring_1) list" where "katsura to n = (let xs = [0..<n] in (distr⇩0 to ((sparse⇩0 [(0, 1)], 1) # (map (λi. (sparse⇩0 [(Suc i, 1)], 2)) xs) @ [(0, -1)])) # (map (katsura_poly to n) xs) )" text ‹For @{prop "1 ≤ n"}, @{term "katsura n"} is a system of ‹n + 1› polynomials in ‹n + 1› indeterminates, with maximum degree ‹2›.› (* Input: n Variables: x(0), ..., x(n) Polynomials: p(0), ..., p(n) p(0) = x(0) + 2 * (x(1) + ... + x(n)) - 1 p(i+1) = (∑j=-n..n. if |i - j| ≤ n then x(|j|) * x(|i - j|) else 0) - x(i) for 0 ≤ i < n *) subsection ‹Eco› definition eco_poly :: "(nat, nat) pp nat_term_order ⇒ nat ⇒ nat ⇒ ((nat, nat) pp ⇒⇩0 'a::comm_ring_1)" where "eco_poly to m i = distr⇩0 to ((sparse⇩0 [(i, 1), (m, 1)], 1) # map (λj. (sparse⇩0 [(j, 1), (j + i + 1, 1), (m, 1)], 1)) [0..<m - i - 1])" definition eco :: "(nat, nat) pp nat_term_order ⇒ nat ⇒ ((nat, nat) pp ⇒⇩0 'a::comm_ring_1) list" where "eco to n = (let m = n - 1 in (distr⇩0 to ((map (λj. (sparse⇩0 [(j, 1)], 1)) [0..<m]) @ [(0, 1)])) # (distr⇩0 to [(sparse⇩0 [(m-1, 1), (m,1)], 1), (0, - of_nat m)]) # (rev (map (eco_poly to m) [0..<m-1])) )" text ‹For @{prop "2 ≤ n"}, @{term "eco n"} is a system of ‹n› polynomials in ‹n› indeterminates, with maximum degree ‹3›.› (* Input: n Define: m ≡ n - 1 Variables: x(0), ..., x(m) Polynomials: p(m), ..., p(0) p(i) = x(i)*x(m) + x(0)*x(i+1)*x(m) + ... + x(m-i-2)*x(m-1)*x(m) for 0 ≤ i < m-1 p(m-1) = x(m-1)*x(m) - m p(m) = x(0) + ... + x(m-1) + 1 *) subsection ‹Noon› definition noon_poly :: "(nat, nat) pp nat_term_order ⇒ nat ⇒ nat ⇒ ((nat, nat) pp ⇒⇩0 'a::comm_ring_1)" where "noon_poly to n i = (let ten = of_nat 10; eleven = - of_nat 11 in distr⇩0 to ((map (λj. if j = i then (sparse⇩0 [(i, 1)], eleven) else (sparse⇩0 [(j, 2), (i, 1)], ten)) [0..<n]) @ [(0, ten)]))" definition noon :: "(nat, nat) pp nat_term_order ⇒ nat ⇒ ((nat, nat) pp ⇒⇩0 'a::comm_ring_1) list" where "noon to n = (noon_poly to n 1) # (noon_poly to n 0) # (map (noon_poly to n) [2..<n])" text ‹For @{prop "2 ≤ n"}, @{term "noon n"} is a system of ‹n› polynomials in ‹n› indeterminates, with maximum degree ‹3›.› (* Input: n Define: m ≡ n - 1 Variables: x(0), ..., x(m) Polynomials: p(1), p(0), p(2), ..., p(m) p(i) = 10 * (x(0)⇧2*x(i) + x(1)⇧2*x(i) + ... + x(i-1)⇧2*x(i) + x(i+1)⇧2*x(i) + ... + x(m)⇧2*x(i)) - 11*x(i) + 10 for 0 ≤ i ≤ m *) (* https://raw.githubusercontent.com/ederc/singular-benchmarks/master/benchs.lib *) end (* theory *)
Theory Algorithm_Schema_Impl
(* Author: Alexander Maletzky *) section ‹Code Equations Related to the Computation of Gr\"obner Bases› theory Algorithm_Schema_Impl imports Algorithm_Schema Benchmarks begin lemma card_keys_MP_oalist [code]: "card_keys (MP_oalist xs) = length (fst (list_of_oalist_ntm xs))" proof - let ?rel = "ko.lt (key_order_of_nat_term_order_inv (snd (list_of_oalist_ntm xs)))" have "irreflp ?rel" by (simp add: irreflp_def) moreover have "transp ?rel" by (simp add: lt_of_nat_term_order_alt) ultimately have *: "distinct (map fst (fst (list_of_oalist_ntm xs)))" using oa_ntm.list_of_oalist_sorted by (rule distinct_sorted_wrt_irrefl) have "card_keys (MP_oalist xs) = length (map fst (fst (list_of_oalist_ntm xs)))" by (simp only: card_keys_def keys_MP_oalist image_set o_def oa_ntm.sorted_domain_def[symmetric], rule distinct_card, fact *) also have "... = length (fst (list_of_oalist_ntm xs))" by simp finally show ?thesis . qed end (* theory *)
Theory Code_Target_Rat
(* Author: Fabian Immler, Alexander Maletzky *) theory Code_Target_Rat imports Complex_Main "HOL-Library.Code_Target_Numeral" begin text ‹Mapping type @{typ rat} to type "Rat.rat" in Isabelle/ML. Serialization for other target languages will be provided in the future.› (* For testing only. *) (* primrec logistic' :: "rat ⇒ rat ⇒ nat ⇒ rat" where "logistic' r x 0 = x" | "logistic' r x (Suc n) = logistic' r (r * x * (rat_of_int 1 - x)) n" definition "logistic n = logistic' (3.6) (0.5) (nat_of_integer n)" ML ‹val logistic_int = @{code logistic}› ML ‹ fun logistic' r x n = (if n = 0 then x else logistic' r (r * x * (Rat.of_int 1 - x)) (n - 1)) fun logistic_ml n = logistic' (Rat.make (36, 10)) (Rat.make (5, 10)) n › *) context includes integer.lifting begin lift_definition rat_of_integer :: "integer ⇒ rat" is Rat.of_int . lift_definition quotient_of' :: "rat ⇒ integer × integer" is quotient_of . lemma [code]: "Rat.of_int (int_of_integer x) = rat_of_integer x" by transfer simp lemma [code_unfold]: "quotient_of = (λx. map_prod int_of_integer int_of_integer (quotient_of' x))" by transfer simp end code_printing type_constructor rat ⇀ (SML) "Rat.rat" | constant "plus :: rat ⇒ _ ⇒ _" ⇀ (SML) "Rat.add" | constant "minus :: rat ⇒ _ ⇒ _" ⇀ (SML) "Rat.add ((_)) (Rat.neg ((_)))" | constant "times :: rat ⇒ _ ⇒ _" ⇀ (SML) "Rat.mult" | constant "inverse :: rat ⇒ _" ⇀ (SML) "Rat.inv" | constant "divide :: rat ⇒ _ ⇒ _" ⇀ (SML) "Rat.mult ((_)) (Rat.inv ((_)))" | constant "rat_of_integer :: integer ⇒ rat" ⇀ (SML) "Rat.of'_int" | constant "abs :: rat ⇒ _" ⇀ (SML) "Rat.abs" | constant "0 :: rat" ⇀ (SML) "!(Rat.make (0, 1))" | constant "1 :: rat" ⇀ (SML) "!(Rat.make (1, 1))" | constant "uminus :: rat ⇒ rat" ⇀ (SML) "Rat.neg" | constant "HOL.equal :: rat ⇒ _" ⇀ (SML) "!((_ : Rat.rat) = _)" | constant "quotient_of'" ⇀ (SML) "Rat.dest" (* For testing only. *) (* ML ‹val logistic_rat = @{code logistic}› ML ‹timeap (fn n => let val r = logistic_int n in r end) 16› (* 2.534s cpu time *) ML ‹timeap (fn n => let val r = logistic_ml n in r end) 16› (* 0.021s cpu time *) ML ‹timeap (fn n => let val r = logistic_rat n in r end) 16› (* 0.021s cpu time *) *) end (* theory *)
Theory Buchberger_Examples
(* Author: Alexander Maletzky *) section ‹Sample Computations with Buchberger's Algorithm› theory Buchberger_Examples imports Buchberger Algorithm_Schema_Impl Code_Target_Rat begin lemma (in gd_term) compute_trd_aux [code]: "trd_aux fs p r = (if is_zero p then r else case find_adds fs (lt p) of None ⇒ trd_aux fs (tail p) (plus_monomial_less r (lc p) (lt p)) | Some f ⇒ trd_aux fs (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f)) r )" by (simp only: trd_aux.simps[of fs p r] plus_monomial_less_def is_zero_def) subsection ‹Scalar Polynomials› global_interpretation punit': gd_powerprod "ord_pp_punit cmp_term" "ord_pp_strict_punit cmp_term" rewrites "punit.adds_term = (adds)" and "punit.pp_of_term = (λx. x)" and "punit.component_of_term = (λ_. ())" and "punit.monom_mult = monom_mult_punit" and "punit.mult_scalar = mult_scalar_punit" and "punit'.punit.min_term = min_term_punit" and "punit'.punit.lt = lt_punit cmp_term" and "punit'.punit.lc = lc_punit cmp_term" and "punit'.punit.tail = tail_punit cmp_term" and "punit'.punit.ord_p = ord_p_punit cmp_term" and "punit'.punit.ord_strict_p = ord_strict_p_punit cmp_term" for cmp_term :: "('a::nat, 'b::{nat,add_wellorder}) pp nat_term_order" defines find_adds_punit = punit'.punit.find_adds and trd_aux_punit = punit'.punit.trd_aux and trd_punit = punit'.punit.trd and spoly_punit = punit'.punit.spoly and count_const_lt_components_punit = punit'.punit.count_const_lt_components and count_rem_components_punit = punit'.punit.count_rem_components and const_lt_component_punit = punit'.punit.const_lt_component and full_gb_punit = punit'.punit.full_gb and add_pairs_single_sorted_punit = punit'.punit.add_pairs_single_sorted and add_pairs_punit = punit'.punit.add_pairs and canon_pair_order_aux_punit = punit'.punit.canon_pair_order_aux and canon_basis_order_punit = punit'.punit.canon_basis_order and new_pairs_sorted_punit = punit'.punit.new_pairs_sorted and product_crit_punit = punit'.punit.product_crit and chain_ncrit_punit = punit'.punit.chain_ncrit and chain_ocrit_punit = punit'.punit.chain_ocrit and apply_icrit_punit = punit'.punit.apply_icrit and apply_ncrit_punit = punit'.punit.apply_ncrit and apply_ocrit_punit = punit'.punit.apply_ocrit and trdsp_punit = punit'.punit.trdsp and gb_sel_punit = punit'.punit.gb_sel and gb_red_aux_punit = punit'.punit.gb_red_aux and gb_red_punit = punit'.punit.gb_red and gb_aux_punit = punit'.punit.gb_aux_punit and gb_punit = punit'.punit.gb_punit ―‹Faster, because incorporates product criterion.› subgoal by (fact gd_powerprod_ord_pp_punit) subgoal by (fact punit_adds_term) subgoal by (simp add: id_def) subgoal by (fact punit_component_of_term) subgoal by (simp only: monom_mult_punit_def) subgoal by (simp only: mult_scalar_punit_def) subgoal using min_term_punit_def by fastforce subgoal by (simp only: lt_punit_def ord_pp_punit_alt) subgoal by (simp only: lc_punit_def ord_pp_punit_alt) subgoal by (simp only: tail_punit_def ord_pp_punit_alt) subgoal by (simp only: ord_p_punit_def ord_pp_strict_punit_alt) subgoal by (simp only: ord_strict_p_punit_def ord_pp_strict_punit_alt) done lemma compute_spoly_punit [code]: "spoly_punit to p q = (let t1 = lt_punit to p; t2 = lt_punit to q; l = lcs t1 t2 in (monom_mult_punit (1 / lc_punit to p) (l - t1) p) - (monom_mult_punit (1 / lc_punit to q) (l - t2) q))" by (simp add: punit'.punit.spoly_def Let_def punit'.punit.lc_def) lemma compute_trd_punit [code]: "trd_punit to fs p = trd_aux_punit to fs p (change_ord to 0)" by (simp only: punit'.punit.trd_def change_ord_def) experiment begin interpretation trivariate⇩0_rat . lemma "lt_punit DRLEX (X⇧2 * Z ^ 3 + 3 * X⇧2 * Y) = sparse⇩0 [(0, 2), (2, 3)]" by eval lemma "lc_punit DRLEX (X⇧2 * Z ^ 3 + 3 * X⇧2 * Y) = 1" by eval lemma "tail_punit DRLEX (X⇧2 * Z ^ 3 + 3 * X⇧2 * Y) = 3 * X⇧2 * Y" by eval lemma "ord_strict_p_punit DRLEX (X⇧2 * Z ^ 4 - 2 * Y ^ 3 * Z⇧2) (X⇧2 * Z ^ 7 + 2 * Y ^ 3 * Z⇧2)" by eval lemma "trd_punit DRLEX [Y⇧2 * Z + 2 * Y * Z ^ 3] (X⇧2 * Z ^ 4 - 2 * Y ^ 3 * Z ^ 3) = X⇧2 * Z ^ 4 + Y ^ 4 * Z" by eval lemma "spoly_punit DRLEX (X⇧2 * Z ^ 4 - 2 * Y ^ 3 * Z⇧2) (Y⇧2 * Z + 2 * Z ^ 3) = -2 * Y ^ 3 * Z⇧2 - (C⇩0 (1 / 2)) * X⇧2 * Y⇧2 * Z⇧2" by eval lemma "gb_punit DRLEX [ (X⇧2 * Z ^ 4 - 2 * Y ^ 3 * Z⇧2, ()), (Y⇧2 * Z + 2 * Z ^ 3, ()) ] () = [ (-2 * Y ^ 3 * Z⇧2 - (C⇩0 (1 / 2)) * X⇧2 * Y⇧2 * Z⇧2, ()), (X⇧2 * Z ^ 4 - 2 * Y ^ 3 * Z⇧2, ()), (Y⇧2 * Z + 2 * Z ^ 3, ()), (- (C⇩0 (1 / 2)) * X⇧2 * Y ^ 4 * Z - 2 * Y ^ 5 * Z, ()) ]" by eval lemma "gb_punit DRLEX [ (X⇧2 * Z⇧2 - Y, ()), (Y⇧2 * Z - 1, ()) ] () = [ (- (Y ^ 3) + X⇧2 * Z, ()), (X⇧2 * Z⇧2 - Y, ()), (Y⇧2 * Z - 1, ()) ]" by eval lemma "gb_punit DRLEX [ (X ^ 3 - X * Y * Z⇧2, ()), (Y⇧2 * Z - 1, ()) ] () = [ (- (X ^ 3 * Y) + X * Z, ()), (X ^ 3 - X * Y * Z⇧2, ()), (Y⇧2 * Z - 1, ()), (- (X * Z ^ 3) + X ^ 5, ()) ]" by eval lemma "gb_punit DRLEX [ (X⇧2 + Y⇧2 + Z⇧2 - 1, ()), (X * Y - Z - 1, ()), (Y⇧2 + X, ()), (Z⇧2 + X, ()) ] () = [ (1, ()) ]" by eval end value [code] "length (gb_punit DRLEX (map (λp. (p, ())) ((katsura DRLEX 2)::(_ ⇒⇩0 rat) list)) ())" value [code] "length (gb_punit DRLEX (map (λp. (p, ())) ((cyclic DRLEX 5)::(_ ⇒⇩0 rat) list)) ())" subsection ‹Vector Polynomials› text ‹We must define the following four constants outside the global interpretation, since otherwise their types are too general.› definition splus_pprod :: "('a::nat, 'b::nat) pp ⇒ _" where "splus_pprod = pprod.splus" definition monom_mult_pprod :: "'c::semiring_0 ⇒ ('a::nat, 'b::nat) pp ⇒ _" where "monom_mult_pprod = pprod.monom_mult" definition mult_scalar_pprod :: "(('a::nat, 'b::nat) pp ⇒⇩0 'c::semiring_0) ⇒ _" where "mult_scalar_pprod = pprod.mult_scalar" definition adds_term_pprod :: "(('a::nat, 'b::nat) pp × _) ⇒ _" where "adds_term_pprod = pprod.adds_term" global_interpretation pprod': gd_nat_term "λx::('a, 'b) pp × 'c. x" "λx. x" cmp_term rewrites "pprod.pp_of_term = fst" and "pprod.component_of_term = snd" and "pprod.splus = splus_pprod" and "pprod.monom_mult = monom_mult_pprod" and "pprod.mult_scalar = mult_scalar_pprod" and "pprod.adds_term = adds_term_pprod" for cmp_term :: "(('a::nat, 'b::nat) pp × 'c::{nat,the_min}) nat_term_order" defines shift_map_keys_pprod = pprod'.shift_map_keys and min_term_pprod = pprod'.min_term and lt_pprod = pprod'.lt and lc_pprod = pprod'.lc and tail_pprod = pprod'.tail and comp_opt_p_pprod = pprod'.comp_opt_p and ord_p_pprod = pprod'.ord_p and ord_strict_p_pprod = pprod'.ord_strict_p and find_adds_pprod = pprod'.find_adds and trd_aux_pprod= pprod'.trd_aux and trd_pprod = pprod'.trd and spoly_pprod = pprod'.spoly and count_const_lt_components_pprod = pprod'.count_const_lt_components and count_rem_components_pprod = pprod'.count_rem_components and const_lt_component_pprod = pprod'.const_lt_component and full_gb_pprod = pprod'.full_gb and keys_to_list_pprod = pprod'.keys_to_list and Keys_to_list_pprod = pprod'.Keys_to_list and add_pairs_single_sorted_pprod = pprod'.add_pairs_single_sorted and add_pairs_pprod = pprod'.add_pairs and canon_pair_order_aux_pprod = pprod'.canon_pair_order_aux and canon_basis_order_pprod = pprod'.canon_basis_order and new_pairs_sorted_pprod = pprod'.new_pairs_sorted and component_crit_pprod = pprod'.component_crit and chain_ncrit_pprod = pprod'.chain_ncrit and chain_ocrit_pprod = pprod'.chain_ocrit and apply_icrit_pprod = pprod'.apply_icrit and apply_ncrit_pprod = pprod'.apply_ncrit and apply_ocrit_pprod = pprod'.apply_ocrit and trdsp_pprod = pprod'.trdsp and gb_sel_pprod = pprod'.gb_sel and gb_red_aux_pprod = pprod'.gb_red_aux and gb_red_pprod = pprod'.gb_red and gb_aux_pprod = pprod'.gb_aux and gb_pprod = pprod'.gb subgoal by (fact gd_nat_term_id) subgoal by (fact pprod_pp_of_term) subgoal by (fact pprod_component_of_term) subgoal by (simp only: splus_pprod_def) subgoal by (simp only: monom_mult_pprod_def) subgoal by (simp only: mult_scalar_pprod_def) subgoal by (simp only: adds_term_pprod_def) done lemma compute_adds_term_pprod [code]: "adds_term_pprod u v = (snd u = snd v ∧ adds_pp_add_linorder (fst u) (fst v))" by (simp add: adds_term_pprod_def pprod.adds_term_def adds_pp_add_linorder_def) lemma compute_splus_pprod [code]: "splus_pprod t (s, i) = (t + s, i)" by (simp add: splus_pprod_def pprod.splus_def) lemma compute_shift_map_keys_pprod [code abstract]: "list_of_oalist_ntm (shift_map_keys_pprod t f xs) = map_raw (λ(k, v). (splus_pprod t k, f v)) (list_of_oalist_ntm xs)" by (simp add: pprod'.list_of_oalist_shift_keys case_prod_beta') lemma compute_trd_pprod [code]: "trd_pprod to fs p = trd_aux_pprod to fs p (change_ord to 0)" by (simp only: pprod'.trd_def change_ord_def) lemmas [code] = conversep_iff definition Vec⇩0 :: "nat ⇒ (('a, nat) pp ⇒⇩0 'b) ⇒ (('a::nat, nat) pp × nat) ⇒⇩0 'b::semiring_1" where "Vec⇩0 i p = mult_scalar_pprod p (Poly_Mapping.single (0, i) 1)" experiment begin interpretation trivariate⇩0_rat . lemma "ord_p_pprod (POT DRLEX) (Vec⇩0 1 (X⇧2 * Z) + Vec⇩0 0 (2 * Y ^ 3 * Z⇧2)) (Vec⇩0 1 (X⇧2 * Z⇧2 + 2 * Y ^ 3 * Z⇧2))" by eval lemma "tail_pprod (POT DRLEX) (Vec⇩0 1 (X⇧2 * Z) + Vec⇩0 0 (2 * Y ^ 3 * Z⇧2)) = Vec⇩0 0 (2 * Y ^ 3 * Z⇧2)" by eval lemma "lt_pprod (POT DRLEX) (Vec⇩0 1 (X⇧2 * Z) + Vec⇩0 0 (2 * Y ^ 3 * Z⇧2)) = (sparse⇩0 [(0, 2), (2, 1)], 1)" by eval lemma "keys (Vec⇩0 0 (X⇧2 * Z ^ 3) + Vec⇩0 1 (2 * Y ^ 3 * Z⇧2)) = {(sparse⇩0 [(0, 2), (2, 3)], 0), (sparse⇩0 [(1, 3), (2, 2)], 1)}" by eval lemma "keys (Vec⇩0 0 (X⇧2 * Z ^ 3) + Vec⇩0 2 (2 * Y ^ 3 * Z⇧2)) = {(sparse⇩0 [(0, 2), (2, 3)], 0), (sparse⇩0 [(1, 3), (2, 2)], 2)}" by eval lemma "Vec⇩0 1 (X⇧2 * Z ^ 7 + 2 * Y ^ 3 * Z⇧2) + Vec⇩0 3 (X⇧2 * Z ^ 4) + Vec⇩0 1 (- 2 * Y ^ 3 * Z⇧2) = Vec⇩0 1 (X⇧2 * Z ^ 7) + Vec⇩0 3 (X⇧2 * Z ^ 4)" by eval lemma "lookup (Vec⇩0 0 (X⇧2 * Z ^ 7) + Vec⇩0 1 (2 * Y ^ 3 * Z⇧2 + 2)) (sparse⇩0 [(0, 2), (2, 7)], 0) = 1" by eval lemma "lookup (Vec⇩0 0 (X⇧2 * Z ^ 7) + Vec⇩0 1 (2 * Y ^ 3 * Z⇧2 + 2)) (sparse⇩0 [(0, 2), (2, 7)], 1) = 0" by eval lemma "Vec⇩0 0 (0 * X^2 * Z^7) + Vec⇩0 1 (0 * Y^3*Z⇧2) = 0" by eval lemma "monom_mult_pprod 3 (sparse⇩0 [(1, 2::nat)]) (Vec⇩0 0 (X⇧2 * Z) + Vec⇩0 1 (2 * Y ^ 3 * Z⇧2)) = Vec⇩0 0 (3 * Y⇧2 * Z * X⇧2) + Vec⇩0 1 (6 * Y ^ 5 * Z⇧2)" by eval lemma "trd_pprod DRLEX [Vec⇩0 0 (Y⇧2 * Z + 2 * Y * Z ^ 3)] (Vec⇩0 0 (X⇧2 * Z ^ 4 - 2 * Y ^ 3 * Z ^ 3)) = Vec⇩0 0 (X⇧2 * Z ^ 4 + Y ^ 4 * Z)" by eval lemma "length (gb_pprod (POT DRLEX) [ (Vec⇩0 0 (X⇧2 * Z ^ 4 - 2 * Y ^ 3 * Z⇧2), ()), (Vec⇩0 0 (Y⇧2 * Z + 2 * Z ^ 3), ()) ] ()) = 4" by eval end end (* theory *)
Theory More_MPoly_Type_Class
(* Author: Alexander Maletzky *) section ‹Further Properties of Multivariate Polynomials› theory More_MPoly_Type_Class imports Polynomials.MPoly_Type_Class_Ordered General begin text ‹Some further general properties of (ordered) multivariate polynomials needed for Gr\"obner bases. This theory is an extension of @{theory Polynomials.MPoly_Type_Class_Ordered}.› subsection ‹Modules and Linear Hulls› context module begin lemma span_listE: assumes "p ∈ span (set bs)" obtains qs where "length qs = length bs" and "p = sum_list (map2 (*s) qs bs)" proof - have "finite (set bs)" .. from this assms obtain q where p: "p = (∑b∈set bs. (q b) *s b)" by (rule span_finiteE) let ?qs = "map_dup q (λ_. 0) bs" show ?thesis proof show "length ?qs = length bs" by simp next let ?zs = "zip (map q (remdups bs)) (remdups bs)" have *: "distinct ?zs" by (rule distinct_zipI2, rule distinct_remdups) have inj: "inj_on (λb. (q b, b)) (set bs)" by (rule, simp) have "p = (∑(q, b)←?zs. q *s b)" by (simp add: sum_list_distinct_conv_sum_set[OF *] set_zip_map1 p comm_monoid_add_class.sum.reindex[OF inj]) also have "... = (∑(q, b)←(filter (λ(q, b). q ≠ 0) ?zs). q *s b)" by (rule monoid_add_class.sum_list_map_filter[symmetric], auto) also have "... = (∑(q, b)←(filter (λ(q, b). q ≠ 0) (zip ?qs bs)). q *s b)" by (simp only: filter_zip_map_dup_const) also have "... = (∑(q, b)←zip ?qs bs. q *s b)" by (rule monoid_add_class.sum_list_map_filter, auto) finally show "p = (∑(q, b)←zip ?qs bs. q *s b)" . qed qed lemma span_listI: "sum_list (map2 (*s) qs bs) ∈ span (set bs)" proof (induct qs arbitrary: bs) case Nil show ?case by (simp add: span_zero) next case step: (Cons q qs) show ?case proof (simp add: zip_Cons1 span_zero split: list.split, intro allI impI) fix a as have "sum_list (map2 (*s) qs as) ∈ span (insert a (set as))" (is "?x ∈ ?A") by (rule, fact step, rule span_mono, auto) moreover have "a ∈ ?A" by (rule span_base) simp ultimately show "q *s a + ?x ∈ ?A" by (intro span_add span_scale) qed qed end lemma (in term_powerprod) monomial_1_in_pmdlI: assumes "(f::_ ⇒⇩0 'b::field) ∈ pmdl F" and "keys f = {t}" shows "monomial 1 t ∈ pmdl F" proof - define c where "c ≡ lookup f t" from assms(2) have f_eq: "f = monomial c t" unfolding c_def by (metis (mono_tags, lifting) Diff_insert_absorb cancel_comm_monoid_add_class.add_cancel_right_right plus_except insert_absorb insert_not_empty keys_eq_empty keys_except) from assms(2) have "c ≠ 0" unfolding c_def by auto hence "monomial 1 t = monom_mult (1 / c) 0 f" by (simp add: f_eq monom_mult_monomial term_simps) also from assms(1) have "... ∈ pmdl F" by (rule pmdl_closed_monom_mult) finally show ?thesis . qed subsection ‹Ordered Polynomials› context ordered_term begin subsubsection ‹Sets of Leading Terms and -Coefficients› definition lt_set :: "('t, 'b::zero) poly_mapping set ⇒ 't set" where "lt_set F = lt ` (F - {0})" definition lc_set :: "('t, 'b::zero) poly_mapping set ⇒ 'b set" where "lc_set F = lc ` (F - {0})" lemma lt_setI: assumes "f ∈ F" and "f ≠ 0" shows "lt f ∈ lt_set F" unfolding lt_set_def using assms by simp lemma lt_setE: assumes "t ∈ lt_set F" obtains f where "f ∈ F" and "f ≠ 0" and "lt f = t" using assms unfolding lt_set_def by auto lemma lt_set_iff: shows "t ∈ lt_set F ⟷ (∃f∈F. f ≠ 0 ∧ lt f = t)" unfolding lt_set_def by auto lemma lc_setI: assumes "f ∈ F" and "f ≠ 0" shows "lc f ∈ lc_set F" unfolding lc_set_def using assms by simp lemma lc_setE: assumes "c ∈ lc_set F" obtains f where "f ∈ F" and "f ≠ 0" and "lc f = c" using assms unfolding lc_set_def by auto lemma lc_set_iff: shows "c ∈ lc_set F ⟷ (∃f∈F. f ≠ 0 ∧ lc f = c)" unfolding lc_set_def by auto lemma lc_set_nonzero: shows "0 ∉ lc_set F" proof assume "0 ∈ lc_set F" then obtain f where "f ∈ F" and "f ≠ 0" and "lc f = 0" by (rule lc_setE) from ‹f ≠ 0› have "lc f ≠ 0" by (rule lc_not_0) from this ‹lc f = 0› show False .. qed lemma lt_sum_distinct_eq_Max: assumes "finite I" and "sum p I ≠ 0" and "⋀i1 i2. i1 ∈ I ⟹ i2 ∈ I ⟹ p i1 ≠ 0 ⟹ p i2 ≠ 0 ⟹ lt (p i1) = lt (p i2) ⟹ i1 = i2" shows "lt (sum p I) = ord_term_lin.Max (lt_set (p ` I))" proof - have "¬ p ` I ⊆ {0}" proof assume "p ` I ⊆ {0}" hence "sum p I = 0" by (rule sum_poly_mapping_eq_zeroI) with assms(2) show False .. qed from assms(1) this assms(3) show ?thesis proof (induct I) case empty from empty(1) show ?case by simp next case (insert x I) show ?case proof (cases "p ` I ⊆ {0}") case True hence "p ` I - {0} = {}" by simp have "p x ≠ 0" proof assume "p x = 0" with True have " p ` insert x I ⊆ {0}" by simp with insert(4) show False .. qed hence "insert (p x) (p ` I) - {0} = insert (p x) (p ` I - {0})" by auto hence "lt_set (p ` insert x I) = {lt (p x)}" by (simp add: lt_set_def ‹p ` I - {0} = {}›) hence eq1: "ord_term_lin.Max (lt_set (p ` insert x I)) = lt (p x)" by simp have eq2: "sum p I = 0" proof (rule ccontr) assume "sum p I ≠ 0" then obtain y where "y ∈ I" and "p y ≠ 0" by (rule sum.not_neutral_contains_not_neutral) with True show False by auto qed show ?thesis by (simp only: eq1 sum.insert[OF insert(1) insert(2)], simp add: eq2) next case False hence IH: "lt (sum p I) = ord_term_lin.Max (lt_set (p ` I))" proof (rule insert(3)) fix i1 i2 assume "i1 ∈ I" and "i2 ∈ I" hence "i1 ∈ insert x I" and "i2 ∈ insert x I" by simp_all moreover assume "p i1 ≠ 0" and "p i2 ≠ 0" and "lt (p i1) = lt (p i2)" ultimately show "i1 = i2" by (rule insert(5)) qed show ?thesis proof (cases "p x = 0") case True hence eq: "lt_set (p ` insert x I) = lt_set (p ` I)" by (simp add: lt_set_def) show ?thesis by (simp only: eq, simp add: sum.insert[OF insert(1) insert(2)] True, fact IH) next case False hence eq1: "lt_set (p ` insert x I) = insert (lt (p x)) (lt_set (p ` I))" by (auto simp add: lt_set_def) from insert(1) have "finite (lt_set (p ` I))" by (simp add: lt_set_def) moreover from ‹¬ p ` I ⊆ {0}› have "lt_set (p ` I) ≠ {}" by (simp add: lt_set_def) ultimately have eq2: "ord_term_lin.Max (insert (lt (p x)) (lt_set (p ` I))) = ord_term_lin.max (lt (p x)) (ord_term_lin.Max (lt_set (p ` I)))" by (rule ord_term_lin.Max_insert) show ?thesis proof (simp only: eq1, simp add: sum.insert[OF insert(1) insert(2)] eq2 IH[symmetric], rule lt_plus_distinct_eq_max, rule) assume *: "lt (p x) = lt (sum p I)" have "lt (p x) ∈ lt_set (p ` I)" by (simp only: * IH, rule ord_term_lin.Max_in, fact+) then obtain f where "f ∈ p ` I" and "f ≠ 0" and ltf: "lt f = lt (p x)" by (rule lt_setE) from this(1) obtain y where "y ∈ I" and "f = p y" .. from this(2) ‹f ≠ 0› ltf have "p y ≠ 0" and lt_eq: "lt (p y) = lt (p x)" by simp_all from _ _ this(1) ‹p x ≠ 0› this(2) have "y = x" proof (rule insert(5)) from ‹y ∈ I› show "y ∈ insert x I" by simp next show "x ∈ insert x I" by simp qed with ‹y ∈ I› have "x ∈ I" by simp with ‹x ∉ I› show False .. qed qed qed qed qed lemma lt_sum_distinct_in_lt_set: assumes "finite I" and "sum p I ≠ 0" and "⋀i1 i2. i1 ∈ I ⟹ i2 ∈ I ⟹ p i1 ≠ 0 ⟹ p i2 ≠ 0 ⟹ lt (p i1) = lt (p i2) ⟹ i1 = i2" shows "lt (sum p I) ∈ lt_set (p ` I)" proof - have "¬ p ` I ⊆ {0}" proof assume "p ` I ⊆ {0}" hence "sum p I = 0" by (rule sum_poly_mapping_eq_zeroI) with assms(2) show False .. qed have "lt (sum p I) = ord_term_lin.Max (lt_set (p ` I))" by (rule lt_sum_distinct_eq_Max, fact+) also have "... ∈ lt_set (p ` I)" proof (rule ord_term_lin.Max_in) from assms(1) show "finite (lt_set (p ` I))" by (simp add: lt_set_def) next from ‹¬ p ` I ⊆ {0}› show "lt_set (p ` I) ≠ {}" by (simp add: lt_set_def) qed finally show ?thesis . qed subsubsection ‹Monicity› definition monic :: "('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b::field)" where "monic p = monom_mult (1 / lc p) 0 p" definition is_monic_set :: "('t ⇒⇩0 'b::field) set ⇒ bool" where "is_monic_set B ≡ (∀b∈B. b ≠ 0 ⟶ lc b = 1)" lemma lookup_monic: "lookup (monic p) v = (lookup p v) / lc p" proof - have "lookup (monic p) (0 ⊕ v) = (1 / lc p) * (lookup p v)" unfolding monic_def by (rule lookup_monom_mult_plus) thus ?thesis by (simp add: term_simps) qed lemma lookup_monic_lt: assumes "p ≠ 0" shows "lookup (monic p) (lt p) = 1" unfolding monic_def proof - from assms have "lc p ≠ 0" by (rule lc_not_0) hence "1 / lc p ≠ 0" by simp let ?q = "monom_mult (1 / lc p) 0 p" have "lookup ?q (0 ⊕ lt p) = (1 / lc p) * (lookup p (lt p))" by (rule lookup_monom_mult_plus) also have "... = (1 / lc p) * lc p" unfolding lc_def .. also have "... = 1" using ‹lc p ≠ 0› by simp finally have "lookup ?q (0 ⊕ lt p) = 1" . thus "lookup ?q (lt p) = 1" by (simp add: term_simps) qed lemma monic_0 [simp]: "monic 0 = 0" unfolding monic_def by (rule monom_mult_zero_right) lemma monic_0_iff: "(monic p = 0) ⟷ (p = 0)" proof assume "monic p = 0" show "p = 0" proof (rule ccontr) assume "p ≠ 0" hence "lookup (monic p) (lt p) = 1" by (rule lookup_monic_lt) with ‹monic p = 0› have "lookup 0 (lt p) = (1::'b)" by simp thus False by simp qed next assume p0: "p = 0" show "monic p = 0" unfolding p0 by (fact monic_0) qed lemma keys_monic [simp]: "keys (monic p) = keys p" proof (cases "p = 0") case True show ?thesis unfolding True monic_0 .. next case False hence "lc p ≠ 0" by (rule lc_not_0) show ?thesis by (rule set_eqI, simp add: in_keys_iff lookup_monic ‹lc p ≠ 0›) qed lemma lt_monic [simp]: "lt (monic p) = lt p" proof (cases "p = 0") case True show ?thesis unfolding True monic_0 .. next case False have "lt (monom_mult (1 / lc p) 0 p) = 0 ⊕ lt p" proof (rule lt_monom_mult) from False have "lc p ≠ 0" by (rule lc_not_0) thus "1 / lc p ≠ 0" by simp qed fact thus ?thesis by (simp add: monic_def term_simps) qed lemma lc_monic: assumes "p ≠ 0" shows "lc (monic p) = 1" using assms by (simp add: lc_def lookup_monic_lt) lemma mult_lc_monic: assumes "p ≠ 0" shows "monom_mult (lc p) 0 (monic p) = p" (is "?q = p") proof (rule poly_mapping_eqI) fix v from assms have "lc p ≠ 0" by (rule lc_not_0) have "lookup ?q (0 ⊕ v) = (lc p) * (lookup (monic p) v)" by (rule lookup_monom_mult_plus) also have "... = (lc p) * ((lookup p v) / lc p)" by (simp add: lookup_monic) also have "... = lookup p v" using ‹lc p ≠ 0› by simp finally show "lookup ?q v = lookup p v" by (simp add: term_simps) qed lemma is_monic_setI: assumes "⋀b. b ∈ B ⟹ b ≠ 0 ⟹ lc b = 1" shows "is_monic_set B" unfolding is_monic_set_def using assms by auto lemma is_monic_setD: assumes "is_monic_set B" and "b ∈ B" and "b ≠ 0" shows "lc b = 1" using assms unfolding is_monic_set_def by auto lemma Keys_image_monic [simp]: "Keys (monic ` A) = Keys A" by (simp add: Keys_def) lemma image_monic_is_monic_set: "is_monic_set (monic ` A)" proof (rule is_monic_setI) fix p assume pin: "p ∈ monic ` A" and "p ≠ 0" from pin obtain p' where p_def: "p = monic p'" and "p' ∈ A" .. from ‹p ≠ 0› have "p' ≠ 0" unfolding p_def monic_0_iff . thus "lc p = 1" unfolding p_def by (rule lc_monic) qed lemma pmdl_image_monic [simp]: "pmdl (monic ` B) = pmdl B" proof show "pmdl (monic ` B) ⊆ pmdl B" proof fix p assume "p ∈ pmdl (monic ` B)" thus "p ∈ pmdl B" proof (induct p rule: pmdl_induct) case base: module_0 show ?case by (fact pmdl.span_zero) next case ind: (module_plus a b c t) from ind(3) obtain b' where b_def: "b = monic b'" and "b' ∈ B" .. have eq: "b = monom_mult (1 / lc b') 0 b'" by (simp only: b_def monic_def) show ?case unfolding eq monom_mult_assoc by (rule pmdl.span_add, fact, rule monom_mult_in_pmdl, fact) qed qed next show "pmdl B ⊆ pmdl (monic ` B)" proof fix p assume "p ∈ pmdl B" thus "p ∈ pmdl (monic ` B)" proof (induct p rule: pmdl_induct) case base: module_0 show ?case by (fact pmdl.span_zero) next case ind: (module_plus a b c t) show ?case proof (cases "b = 0") case True from ind(2) show ?thesis by (simp add: True) next case False let ?b = "monic b" from ind(3) have "?b ∈ monic ` B" by (rule imageI) have "a + monom_mult c t (monom_mult (lc b) 0 ?b) ∈ pmdl (monic ` B)" unfolding monom_mult_assoc by (rule pmdl.span_add, fact, rule monom_mult_in_pmdl, fact) thus ?thesis unfolding mult_lc_monic[OF False] . qed qed qed qed end (* ordered_term *) end (* theory *)
Theory Auto_Reduction
(* Author: Alexander Maletzky *) section ‹Auto-reducing Lists of Polynomials› theory Auto_Reduction imports Reduction More_MPoly_Type_Class begin subsection ‹Reduction and Monic Sets› context ordered_term begin lemma is_red_monic: "is_red B (monic p) ⟷ is_red B p" unfolding is_red_adds_iff keys_monic .. lemma red_image_monic [simp]: "red (monic ` B) = red B" proof (rule, rule) fix p q show "red (monic ` B) p q ⟷ red B p q" proof assume "red (monic ` B) p q" then obtain f t where "f ∈ monic ` B" and *: "red_single p q f t" by (rule red_setE) from this(1) obtain g where "g ∈ B" and "f = monic g" .. from * have "f ≠ 0" by (simp add: red_single_def) hence "g ≠ 0" by (simp add: monic_0_iff ‹f = monic g›) hence "lc g ≠ 0" by (rule lc_not_0) have eq: "monom_mult (lc g) 0 f = g" by (simp add: ‹f = monic g› mult_lc_monic[OF ‹g ≠ 0›]) from ‹g ∈ B› show "red B p q" proof (rule red_setI) from * ‹lc g ≠ 0› have "red_single p q (monom_mult (lc g) 0 f) t" by (rule red_single_mult_const) thus "red_single p q g t" by (simp only: eq) qed next assume "red B p q" then obtain f t where "f ∈ B" and *: "red_single p q f t" by (rule red_setE) from * have "f ≠ 0" by (simp add: red_single_def) hence "lc f ≠ 0" by (rule lc_not_0) hence "1 / lc f ≠ 0" by simp from ‹f ∈ B› have "monic f ∈ monic ` B" by (rule imageI) thus "red (monic ` B) p q" proof (rule red_setI) from * ‹1 / lc f ≠ 0› show "red_single p q (monic f) t" unfolding monic_def by (rule red_single_mult_const) qed qed qed lemma is_red_image_monic [simp]: "is_red (monic ` B) p ⟷ is_red B p" by (simp add: is_red_def) subsection ‹Minimal Bases and Auto-reduced Bases› definition is_auto_reduced :: "('t ⇒⇩0 'b::field) set ⇒ bool" where "is_auto_reduced B ≡ (∀b∈B. ¬ is_red (B - {b}) b)" definition is_minimal_basis :: "('t ⇒⇩0 'b::zero) set ⇒ bool" where "is_minimal_basis B ⟷ (0 ∉ B ∧ (∀p q. p ∈ B ⟶ q ∈ B ⟶ p ≠ q ⟶ ¬ lt p adds⇩t lt q))" lemma is_auto_reducedD: assumes "is_auto_reduced B" and "b ∈ B" shows "¬ is_red (B - {b}) b" using assms unfolding is_auto_reduced_def by auto text ‹The converse of the following lemma is only true if @{term B} is minimal!› lemma image_monic_is_auto_reduced: assumes "is_auto_reduced B" shows "is_auto_reduced (monic ` B)" unfolding is_auto_reduced_def proof fix b assume "b ∈ monic ` B" then obtain b' where b_def: "b = monic b'" and "b' ∈ B" .. from assms ‹b' ∈ B› have nred: "¬ is_red (B - {b'}) b'" by (rule is_auto_reducedD) show "¬ is_red ((monic ` B) - {b}) b" proof assume red: "is_red ((monic ` B) - {b}) b" have "(monic ` B) - {b} ⊆ monic ` (B - {b'})" unfolding b_def by auto with red have "is_red (monic ` (B - {b'})) b" by (rule is_red_subset) hence "is_red (B - {b'}) b'" unfolding b_def is_red_monic is_red_image_monic . with nred show False .. qed qed lemma is_minimal_basisI: assumes "⋀p. p ∈ B ⟹ p ≠ 0" and "⋀p q. p ∈ B ⟹ q ∈ B ⟹ p ≠ q ⟹ ¬ lt p adds⇩t lt q" shows "is_minimal_basis B" unfolding is_minimal_basis_def using assms by auto lemma is_minimal_basisD1: assumes "is_minimal_basis B" and "p ∈ B" shows "p ≠ 0" using assms unfolding is_minimal_basis_def by auto lemma is_minimal_basisD2: assumes "is_minimal_basis B" and "p ∈ B" and "q ∈ B" and "p ≠ q" shows "¬ lt p adds⇩t lt q" using assms unfolding is_minimal_basis_def by auto lemma is_minimal_basisD3: assumes "is_minimal_basis B" and "p ∈ B" and "q ∈ B" and "p ≠ q" shows "¬ lt q adds⇩t lt p" using assms unfolding is_minimal_basis_def by auto lemma is_minimal_basis_subset: assumes "is_minimal_basis B" and "A ⊆ B" shows "is_minimal_basis A" proof (intro is_minimal_basisI) fix p assume "p ∈ A" with ‹A ⊆ B› have "p ∈ B" .. with ‹is_minimal_basis B› show "p ≠ 0" by (rule is_minimal_basisD1) next fix p q assume "p ∈ A" and "q ∈ A" and "p ≠ q" from ‹p ∈ A› and ‹q ∈ A› have "p ∈ B" and "q ∈ B" using ‹A ⊆ B› by auto from ‹is_minimal_basis B› this ‹p ≠ q› show " ¬ lt p adds⇩t lt q" by (rule is_minimal_basisD2) qed lemma nadds_red: assumes nadds: "⋀q. q ∈ B ⟹ ¬ lt q adds⇩t lt p" and red: "red B p r" shows "r ≠ 0 ∧ lt r = lt p" proof - from red obtain q t where "q ∈ B" and rs: "red_single p r q t" by (rule red_setE) from rs have "q ≠ 0" and "lookup p (t ⊕ lt q) ≠ 0" and r_def: "r = p - monom_mult (lookup p (t ⊕ lt q) / lc q) t q" unfolding red_single_def by simp_all have "t ⊕ lt q ≼⇩t lt p" by (rule lt_max, fact) moreover have "t ⊕ lt q ≠ lt p" proof assume "t ⊕ lt q = lt p" hence "lt q adds⇩t lt p" by (metis adds_term_triv) with nadds[OF ‹q ∈ B›] show False .. qed ultimately have "t ⊕ lt q ≺⇩t lt p" by simp let ?m = "monom_mult (lookup p (t ⊕ lt q) / lc q) t q" from ‹lookup p (t ⊕ lt q) ≠ 0› lc_not_0[OF ‹q ≠ 0›] have c0: "lookup p (t ⊕ lt q) / lc q ≠ 0" by simp from ‹q ≠ 0› c0 have "?m ≠ 0" by (simp add: monom_mult_eq_zero_iff) have "lt (-?m) = lt ?m" by (fact lt_uminus) also have lt1: "lt ?m = t ⊕ lt q" by (rule lt_monom_mult, fact+) finally have lt2: "lt (-?m) = t ⊕ lt q" . show ?thesis proof show "r ≠ 0" proof assume "r = 0" hence "p = ?m" unfolding r_def by simp with lt1 ‹t ⊕ lt q ≠ lt p› show False by simp qed next have "lt (-?m + p) = lt p" proof (rule lt_plus_eqI) show "lt (-?m) ≺⇩t lt p" unfolding lt2 by fact qed thus "lt r = lt p" unfolding r_def by simp qed qed lemma nadds_red_nonzero: assumes nadds: "⋀q. q ∈ B ⟹ ¬ lt q adds⇩t lt p" and "red B p r" shows "r ≠ 0" using nadds_red[OF assms] by simp lemma nadds_red_lt: assumes nadds: "⋀q. q ∈ B ⟹ ¬ lt q adds⇩t lt p" and "red B p r" shows "lt r = lt p" using nadds_red[OF assms] by simp lemma nadds_red_rtrancl_lt: assumes nadds: "⋀q. q ∈ B ⟹ ¬ lt q adds⇩t lt p" and rtrancl: "(red B)⇧*⇧* p r" shows "lt r = lt p" using rtrancl proof (induct rule: rtranclp_induct) case base show ?case .. next case (step y z) have "lt z = lt y" proof (rule nadds_red_lt) fix q assume "q ∈ B" thus "¬ lt q adds⇩t lt y" unfolding ‹lt y = lt p› by (rule nadds) qed fact with ‹lt y = lt p› show ?case by simp qed lemma nadds_red_rtrancl_nonzero: assumes nadds: "⋀q. q ∈ B ⟹ ¬ lt q adds⇩t lt p" and "p ≠ 0" and rtrancl: "(red B)⇧*⇧* p r" shows "r ≠ 0" using rtrancl proof (induct rule: rtranclp_induct) case base show ?case by fact next case (step y z) from nadds ‹(red B)⇧*⇧* p y› have "lt y = lt p" by (rule nadds_red_rtrancl_lt) show "z ≠ 0" proof (rule nadds_red_nonzero) fix q assume "q ∈ B" thus "¬ lt q adds⇩t lt y" unfolding ‹lt y = lt p› by (rule nadds) qed fact qed lemma minimal_basis_red_rtrancl_nonzero: assumes "is_minimal_basis B" and "p ∈ B" and "(red (B - {p}))⇧*⇧* p r" shows "r ≠ 0" proof (rule nadds_red_rtrancl_nonzero) fix q assume "q ∈ (B - {p})" hence "q ∈ B" and "q ≠ p" by auto show "¬ lt q adds⇩t lt p" by (rule is_minimal_basisD2, fact+) next show "p ≠ 0" by (rule is_minimal_basisD1, fact+) qed fact lemma minimal_basis_red_rtrancl_lt: assumes "is_minimal_basis B" and "p ∈ B" and "(red (B - {p}))⇧*⇧* p r" shows "lt r = lt p" proof (rule nadds_red_rtrancl_lt) fix q assume "q ∈ (B - {p})" hence "q ∈ B" and "q ≠ p" by auto show "¬ lt q adds⇩t lt p" by (rule is_minimal_basisD2, fact+) qed fact lemma is_minimal_basis_replace: assumes major: "is_minimal_basis B" and "p ∈ B" and red: "(red (B - {p}))⇧*⇧* p r" shows "is_minimal_basis (insert r (B - {p}))" proof (rule is_minimal_basisI) fix q assume "q ∈ insert r (B - {p})" hence "q = r ∨ q ∈ B ∧ q ≠ p" by simp thus "q ≠ 0" proof assume "q = r" from assms show ?thesis unfolding ‹q = r› by (rule minimal_basis_red_rtrancl_nonzero) next assume "q ∈ B ∧ q ≠ p" hence "q ∈ B" .. with major show ?thesis by (rule is_minimal_basisD1) qed next fix a b assume "a ∈ insert r (B - {p})" and "b ∈ insert r (B - {p})" and "a ≠ b" from assms have ltr: "lt r = lt p" by (rule minimal_basis_red_rtrancl_lt) from ‹b ∈ insert r (B - {p})› have b: "b = r ∨ b ∈ B ∧ b ≠ p" by simp from ‹a ∈ insert r (B - {p})› have "a = r ∨ a ∈ B ∧ a ≠ p" by simp thus "¬ lt a adds⇩t lt b" proof assume "a = r" hence lta: "lt a = lt p" using ltr by simp from b show ?thesis proof assume "b = r" with ‹a ≠ b› show ?thesis unfolding ‹a = r› by simp next assume "b ∈ B ∧ b ≠ p" hence "b ∈ B" and "p ≠ b" by auto with major ‹p ∈ B› have "¬ lt p adds⇩t lt b" by (rule is_minimal_basisD2) thus ?thesis unfolding lta . qed next assume "a ∈ B ∧ a ≠ p" hence "a ∈ B" and "a ≠ p" by simp_all from b show ?thesis proof assume "b = r" from major ‹a ∈ B› ‹p ∈ B› ‹a ≠ p› have "¬ lt a adds⇩t lt p" by (rule is_minimal_basisD2) thus ?thesis unfolding ‹b = r› ltr by simp next assume "b ∈ B ∧ b ≠ p" hence "b ∈ B" .. from major ‹a ∈ B› ‹b ∈ B› ‹a ≠ b› show ?thesis by (rule is_minimal_basisD2) qed qed qed subsection ‹Computing Minimal Bases› definition comp_min_basis :: "('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b::zero) list" where "comp_min_basis xs = filter_min (λx y. lt x adds⇩t lt y) (filter (λx. x ≠ 0) xs)" lemma comp_min_basis_subset': "set (comp_min_basis xs) ⊆ {x ∈ set xs. x ≠ 0}" proof - have "set (comp_min_basis xs) ⊆ set (filter (λx. x ≠ 0) xs)" unfolding comp_min_basis_def by (rule filter_min_subset) also have "… = {x ∈ set xs. x ≠ 0}" by simp finally show ?thesis . qed lemma comp_min_basis_subset: "set (comp_min_basis xs) ⊆ set xs" proof - have "set (comp_min_basis xs) ⊆ {x ∈ set xs. x ≠ 0}" by (rule comp_min_basis_subset') also have "... ⊆ set xs" by simp finally show ?thesis . qed lemma comp_min_basis_nonzero: "p ∈ set (comp_min_basis xs) ⟹ p ≠ 0" using comp_min_basis_subset' by blast lemma comp_min_basis_adds: assumes "p ∈ set xs" and "p ≠ 0" obtains q where "q ∈ set (comp_min_basis xs)" and "lt q adds⇩t lt p" proof - let ?rel = "(λx y. lt x adds⇩t lt y)" have "transp ?rel" by (auto intro!: transpI dest: adds_term_trans) moreover have "reflp ?rel" by (simp add: reflp_def adds_term_refl) moreover from assms have "p ∈ set (filter (λx. x ≠ 0) xs)" by simp ultimately obtain q where "q ∈ set (comp_min_basis xs)" and "lt q adds⇩t lt p" unfolding comp_min_basis_def by (rule filter_min_relE) thus ?thesis .. qed lemma comp_min_basis_is_red: assumes "is_red (set xs) f" shows "is_red (set (comp_min_basis xs)) f" proof - from assms obtain x t where "x ∈ set xs" and "t ∈ keys f" and "x ≠ 0" and "lt x adds⇩t t" by (rule is_red_addsE) from ‹x ∈ set xs› ‹x ≠ 0› obtain y where yin: "y ∈ set (comp_min_basis xs)" and "lt y adds⇩t lt x" by (rule comp_min_basis_adds) show ?thesis proof (rule is_red_addsI) from ‹lt y adds⇩t lt x› ‹lt x adds⇩t t› show "lt y adds⇩t t" by (rule adds_term_trans) next from yin show "y ≠ 0" by (rule comp_min_basis_nonzero) qed fact+ qed lemma comp_min_basis_nadds: assumes "p ∈ set (comp_min_basis xs)" and "q ∈ set (comp_min_basis xs)" and "p ≠ q" shows "¬ lt q adds⇩t lt p" proof have "transp (λx y. lt x adds⇩t lt y)" by (auto intro!: transpI dest: adds_term_trans) moreover note assms(2, 1) moreover assume "lt q adds⇩t lt p" ultimately have "q = p" unfolding comp_min_basis_def by (rule filter_min_minimal) with assms(3) show False by simp qed lemma comp_min_basis_is_minimal_basis: "is_minimal_basis (set (comp_min_basis xs))" by (rule is_minimal_basisI, rule comp_min_basis_nonzero, assumption, rule comp_min_basis_nadds, assumption+, simp) lemma comp_min_basis_distinct: "distinct (comp_min_basis xs)" unfolding comp_min_basis_def by (rule filter_min_distinct) (simp add: reflp_def adds_term_refl) end (* ordered_term *) subsection ‹Auto-Reduction› context gd_term begin lemma is_minimal_basis_trd_is_minimal_basis: assumes "is_minimal_basis (set (x # xs))" and "x ∉ set xs" shows "is_minimal_basis (set ((trd xs x) # xs))" proof - from assms(1) have "is_minimal_basis (insert (trd xs x) (set (x # xs) - {x}))" proof (rule is_minimal_basis_replace, simp) from assms(2) have eq: "set (x # xs) - {x} = set xs" by simp show "(red (set (x # xs) - {x}))⇧*⇧* x (trd xs x)" unfolding eq by (rule trd_red_rtrancl) qed also from assms(2) have "... = set ((trd xs x) # xs)" by auto finally show ?thesis . qed lemma is_minimal_basis_trd_distinct: assumes min: "is_minimal_basis (set (x # xs))" and dist: "distinct (x # xs)" shows "distinct ((trd xs x) # xs)" proof - let ?y = "trd xs x" from min have lty: "lt ?y = lt x" proof (rule minimal_basis_red_rtrancl_lt, simp) from dist have "x ∉ set xs" by simp hence eq: "set (x # xs) - {x} = set xs" by simp show "(red (set (x # xs) - {x}))⇧*⇧* x (trd xs x)" unfolding eq by (rule trd_red_rtrancl) qed have "?y ∉ set xs" proof assume "?y ∈ set xs" hence "?y ∈ set (x # xs)" by simp with min have "¬ lt ?y adds⇩t lt x" proof (rule is_minimal_basisD2, simp) show "?y ≠ x" proof assume "?y = x" from dist have "x ∉ set xs" by simp with ‹?y ∈ set xs› show False unfolding ‹?y = x› by simp qed qed thus False unfolding lty by (simp add: adds_term_refl) qed moreover from dist have "distinct xs" by simp ultimately show ?thesis by simp qed primrec comp_red_basis_aux :: "('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b::field) list" where comp_red_basis_aux_base: "comp_red_basis_aux Nil ys = ys"| comp_red_basis_aux_rec: "comp_red_basis_aux (x # xs) ys = comp_red_basis_aux xs ((trd (xs @ ys) x) # ys)" lemma subset_comp_red_basis_aux: "set ys ⊆ set (comp_red_basis_aux xs ys)" proof (induct xs arbitrary: ys) case Nil show ?case unfolding comp_red_basis_aux_base .. next case (Cons a xs) have "set ys ⊆ set ((trd (xs @ ys) a) # ys)" by auto also have "... ⊆ set (comp_red_basis_aux xs ((trd (xs @ ys) a) # ys))" by (rule Cons.hyps) finally show ?case unfolding comp_red_basis_aux_rec . qed lemma comp_red_basis_aux_nonzero: assumes "is_minimal_basis (set (xs @ ys))" and "distinct (xs @ ys)" and "p ∈ set (comp_red_basis_aux xs ys)" shows "p ≠ 0" using assms proof (induct xs arbitrary: ys) case Nil show ?case proof (rule is_minimal_basisD1) from Nil(1) show "is_minimal_basis (set ys)" by simp next from Nil(3) show "p ∈ set ys" unfolding comp_red_basis_aux_base . qed next case (Cons a xs) have eq: "(a # xs) @ ys = a # (xs @ ys)" by simp have "a ∈ set (a # xs @ ys)" by simp from Cons(3) have "a ∉ set (xs @ ys)" unfolding eq by simp let ?ys = "trd (xs @ ys) a # ys" show ?case proof (rule Cons.hyps) from Cons(3) have "a ∉ set (xs @ ys)" unfolding eq by simp with Cons(2) show "is_minimal_basis (set (xs @ ?ys))" unfolding set_reorder eq by (rule is_minimal_basis_trd_is_minimal_basis) next from Cons(2) Cons(3) show "distinct (xs @ ?ys)" unfolding distinct_reorder eq by (rule is_minimal_basis_trd_distinct) next from Cons(4) show "p ∈ set (comp_red_basis_aux xs ?ys)" unfolding comp_red_basis_aux_rec . qed qed lemma comp_red_basis_aux_lt: assumes "is_minimal_basis (set (xs @ ys))" and "distinct (xs @ ys)" shows "lt ` set (xs @ ys) = lt ` set (comp_red_basis_aux xs ys)" using assms proof (induct xs arbitrary: ys) case Nil show ?case unfolding comp_red_basis_aux_base by simp next case (Cons a xs) have eq: "(a # xs) @ ys = a # (xs @ ys)" by simp from Cons(3) have a: "a ∉ set (xs @ ys)" unfolding eq by simp let ?b = "trd (xs @ ys) a" let ?ys = "?b # ys" from Cons(2) have "lt ?b = lt a" unfolding eq proof (rule minimal_basis_red_rtrancl_lt, simp) from a have eq2: "set (a # xs @ ys) - {a} = set (xs @ ys)" by simp show "(red (set (a # xs @ ys) - {a}))⇧*⇧* a ?b" unfolding eq2 by (rule trd_red_rtrancl) qed hence "lt ` set ((a # xs) @ ys) = lt ` set ((?b # xs) @ ys)" by simp also have "... = lt ` set (xs @ (?b # ys))" by simp finally have eq2: "lt ` set ((a # xs) @ ys) = lt ` set (xs @ (?b # ys))" . show ?case unfolding comp_red_basis_aux_rec eq2 proof (rule Cons.hyps) from Cons(3) have "a ∉ set (xs @ ys)" unfolding eq by simp with Cons(2) show "is_minimal_basis (set (xs @ ?ys))" unfolding set_reorder eq by (rule is_minimal_basis_trd_is_minimal_basis) next from Cons(2) Cons(3) show "distinct (xs @ ?ys)" unfolding distinct_reorder eq by (rule is_minimal_basis_trd_distinct) qed qed lemma comp_red_basis_aux_pmdl: assumes "is_minimal_basis (set (xs @ ys))" and "distinct (xs @ ys)" shows "pmdl (set (comp_red_basis_aux xs ys)) ⊆ pmdl (set (xs @ ys))" using assms proof (induct xs arbitrary: ys) case Nil show ?case unfolding comp_red_basis_aux_base by simp next case (Cons a xs) have eq: "(a # xs) @ ys = a # (xs @ ys)" by simp from Cons(3) have a: "a ∉ set (xs @ ys)" unfolding eq by simp let ?b = "trd (xs @ ys) a" let ?ys = "?b # ys" have "pmdl (set (comp_red_basis_aux xs ?ys)) ⊆ pmdl (set (xs @ ?ys))" proof (rule Cons.hyps) from Cons(3) have "a ∉ set (xs @ ys)" unfolding eq by simp with Cons(2) show "is_minimal_basis (set (xs @ ?ys))" unfolding set_reorder eq by (rule is_minimal_basis_trd_is_minimal_basis) next from Cons(2) Cons(3) show "distinct (xs @ ?ys)" unfolding distinct_reorder eq by (rule is_minimal_basis_trd_distinct) qed also have "... = pmdl (set (?b # xs @ ys))" by simp also from a have "... = pmdl (insert ?b (set (a # xs @ ys) - {a}))" by auto also have "... ⊆ pmdl (set (a # xs @ ys))" proof (rule pmdl.replace_span) have "a - (trd (xs @ ys) a) ∈ pmdl (set (xs @ ys))" by (rule trd_in_pmdl) have "a - (trd (xs @ ys) a) ∈ pmdl (set (a # xs @ ys))" proof show "pmdl (set (xs @ ys)) ⊆ pmdl (set (a # xs @ ys))" by (rule pmdl.span_mono) auto qed fact hence "- (a - (trd (xs @ ys) a)) ∈ pmdl (set (a # xs @ ys))" by (rule pmdl.span_neg) hence "(trd (xs @ ys) a) - a ∈ pmdl (set (a # xs @ ys))" by simp hence "((trd (xs @ ys) a) - a) + a ∈ pmdl (set (a # xs @ ys))" proof (rule pmdl.span_add) show "a ∈ pmdl (set (a # xs @ ys))" proof show "a ∈ set (a # xs @ ys)" by simp qed (rule pmdl.span_superset) qed thus "trd (xs @ ys) a ∈ pmdl (set (a # xs @ ys))" by simp qed also have "... = pmdl (set ((a # xs) @ ys))" by simp finally show ?case unfolding comp_red_basis_aux_rec . qed lemma comp_red_basis_aux_irred: assumes "is_minimal_basis (set (xs @ ys))" and "distinct (xs @ ys)" and "⋀y. y ∈ set ys ⟹ ¬ is_red (set (xs @ ys) - {y}) y" and "p ∈ set (comp_red_basis_aux xs ys)" shows "¬ is_red (set (comp_red_basis_aux xs ys) - {p}) p" using assms proof (induct xs arbitrary: ys) case Nil have "¬ is_red (set ([] @ ys) - {p}) p" proof (rule Nil(3)) from Nil(4) show "p ∈ set ys" unfolding comp_red_basis_aux_base . qed thus ?case unfolding comp_red_basis_aux_base by simp next case (Cons a xs) have eq: "(a # xs) @ ys = a # (xs @ ys)" by simp from Cons(3) have a_notin: "a ∉ set (xs @ ys)" unfolding eq by simp from Cons(2) have is_min: "is_minimal_basis (set (a # xs @ ys))" unfolding eq . let ?b = "trd (xs @ ys) a" let ?ys = "?b # ys" have dist: "distinct (?b # (xs @ ys))" proof (rule is_minimal_basis_trd_distinct, fact is_min) from Cons(3) show "distinct (a # xs @ ys)" unfolding eq . qed show ?case unfolding comp_red_basis_aux_rec proof (rule Cons.hyps) from Cons(2) a_notin show "is_minimal_basis (set (xs @ ?ys))" unfolding set_reorder eq by (rule is_minimal_basis_trd_is_minimal_basis) next from dist show "distinct (xs @ ?ys)" unfolding distinct_reorder . next fix y assume "y ∈ set ?ys" hence "y = ?b ∨ y ∈ set ys" by simp thus "¬ is_red (set (xs @ ?ys) - {y}) y" proof assume "y = ?b" from dist have "?b ∉ set (xs @ ys)" by simp hence eq3: "set (xs @ ?ys) - {?b} = set (xs @ ys)" unfolding set_reorder by simp have "¬ is_red (set (xs @ ys)) ?b" by (rule trd_irred) thus ?thesis unfolding ‹y = ?b› eq3 . next assume "y ∈ set ys" hence irred: "¬ is_red (set ((a # xs) @ ys) - {y}) y" by (rule Cons(4)) from ‹y ∈ set ys› a_notin have "y ≠ a" by auto hence eq3: "set ((a # xs) @ ys) - {y} = {a} ∪ (set (xs @ ys) - {y})" by auto from irred have i1: "¬ is_red {a} y" and i2: "¬ is_red (set (xs @ ys) - {y}) y" unfolding eq3 is_red_union by simp_all show ?thesis unfolding set_reorder proof (cases "y = ?b") case True from i2 show "¬ is_red (set (?b # xs @ ys) - {y}) y" by (simp add: True) next case False hence eq4: "set (?b # xs @ ys) - {y} = {?b} ∪ (set (xs @ ys) - {y})" by auto show "¬ is_red (set (?b # xs @ ys) - {y}) y" unfolding eq4 proof assume "is_red ({?b} ∪ (set (xs @ ys) - {y})) y" thus False unfolding is_red_union proof have ltb: "lt ?b = lt a" proof (rule minimal_basis_red_rtrancl_lt, fact is_min) show "a ∈ set (a # xs @ ys)" by simp next from a_notin have eq: "set (a # xs @ ys) - {a} = set (xs @ ys)" by simp show "(red (set (a # xs @ ys) - {a}))⇧*⇧* a ?b" unfolding eq by (rule trd_red_rtrancl) qed assume "is_red {?b} y" then obtain t where "t ∈ keys y" and "lt ?b adds⇩t t" unfolding is_red_adds_iff by auto with ltb have "lt a adds⇩t t" by simp have "is_red {a} y" by (rule is_red_addsI, rule, rule is_minimal_basisD1, fact is_min, simp, fact+) with i1 show False .. next assume "is_red (set (xs @ ys) - {y}) y" with i2 show False .. qed qed qed qed next from Cons(5) show "p ∈ set (comp_red_basis_aux xs ?ys)" unfolding comp_red_basis_aux_rec . qed qed lemma comp_red_basis_aux_dgrad_p_set_le: assumes "dickson_grading d" shows "dgrad_p_set_le d (set (comp_red_basis_aux xs ys)) (set xs ∪ set ys)" proof (induct xs arbitrary: ys) case Nil show ?case by (simp, rule dgrad_p_set_le_subset, fact subset_refl) next case (Cons x xs) let ?h = "trd (xs @ ys) x" have "dgrad_p_set_le d (set (comp_red_basis_aux xs (?h # ys))) (set xs ∪ set (?h # ys))" by (fact Cons) also have "... = insert ?h (set xs ∪ set ys)" by simp also have "dgrad_p_set_le d ... (insert x (set xs ∪ set ys))" proof (rule dgrad_p_set_leI_insert) show "dgrad_p_set_le d (set xs ∪ set ys) (insert x (set xs ∪ set ys))" by (rule dgrad_p_set_le_subset, blast) next have "(red (set (xs @ ys)))⇧*⇧* x ?h" by (rule trd_red_rtrancl) with assms have "dgrad_p_set_le d {?h} (insert x (set (xs @ ys)))" by (rule dgrad_p_set_le_red_rtrancl) thus "dgrad_p_set_le d {?h} (insert x (set xs ∪ set ys))" by simp qed finally show ?case by simp qed definition comp_red_basis :: "('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b::field) list" where "comp_red_basis xs = comp_red_basis_aux (comp_min_basis xs) []" lemma comp_red_basis_nonzero: assumes "p ∈ set (comp_red_basis xs)" shows "p ≠ 0" proof - have "is_minimal_basis (set ((comp_min_basis xs) @ []))" by (simp add: comp_min_basis_is_minimal_basis) moreover have "distinct ((comp_min_basis xs) @ [])" by (simp add: comp_min_basis_distinct) moreover from assms have "p ∈ set (comp_red_basis_aux (comp_min_basis xs) [])" unfolding comp_red_basis_def . ultimately show ?thesis by (rule comp_red_basis_aux_nonzero) qed lemma pmdl_comp_red_basis_subset: "pmdl (set (comp_red_basis xs)) ⊆ pmdl (set xs)" proof fix f assume fin: "f ∈ pmdl (set (comp_red_basis xs))" have "f ∈ pmdl (set (comp_min_basis xs))" proof from fin show "f ∈ pmdl (set (comp_red_basis_aux (comp_min_basis xs) []))" unfolding comp_red_basis_def . next have "pmdl (set (comp_red_basis_aux (comp_min_basis xs) [])) ⊆ pmdl (set ((comp_min_basis xs) @ []))" by (rule comp_red_basis_aux_pmdl, simp_all, rule comp_min_basis_is_minimal_basis, rule comp_min_basis_distinct) thus "pmdl (set (comp_red_basis_aux (comp_min_basis xs) [])) ⊆ pmdl (set (comp_min_basis xs))" by simp qed also from comp_min_basis_subset have "... ⊆ pmdl (set xs)" by (rule pmdl.span_mono) finally show "f ∈ pmdl (set xs)" . qed lemma comp_red_basis_adds: assumes "p ∈ set xs" and "p ≠ 0" obtains q where "q ∈ set (comp_red_basis xs)" and "lt q adds⇩t lt p" proof - from assms obtain q1 where "q1 ∈ set (comp_min_basis xs)" and "lt q1 adds⇩t lt p" by (rule comp_min_basis_adds) from ‹q1 ∈ set (comp_min_basis xs)› have "lt q1 ∈ lt ` set (comp_min_basis xs)" by simp also have "... = lt ` set ((comp_min_basis xs) @ [])" by simp also have "... = lt ` set (comp_red_basis_aux (comp_min_basis xs) [])" by (rule comp_red_basis_aux_lt, simp_all, rule comp_min_basis_is_minimal_basis, rule comp_min_basis_distinct) finally obtain q where "q ∈ set (comp_red_basis_aux (comp_min_basis xs) [])" and "lt q = lt q1" by auto show ?thesis proof show "q ∈ set (comp_red_basis xs)" unfolding comp_red_basis_def by fact next from ‹lt q1 adds⇩t lt p› show "lt q adds⇩t lt p" unfolding ‹lt q = lt q1› . qed qed lemma comp_red_basis_lt: assumes "p ∈ set (comp_red_basis xs)" obtains q where "q ∈ set xs" and "q ≠ 0" and "lt q = lt p" proof - have eq: "lt ` set ((comp_min_basis xs) @ []) = lt ` set (comp_red_basis_aux (comp_min_basis xs) [])" by (rule comp_red_basis_aux_lt, simp_all, rule comp_min_basis_is_minimal_basis, rule comp_min_basis_distinct) from assms have "lt p ∈ lt ` set (comp_red_basis xs)" by simp also have "... = lt ` set (comp_red_basis_aux (comp_min_basis xs) [])" unfolding comp_red_basis_def .. also have "... = lt ` set (comp_min_basis xs)" unfolding eq[symmetric] by simp finally obtain q where "q ∈ set (comp_min_basis xs)" and "lt q = lt p" by auto show ?thesis proof show "q ∈ set xs" by (rule, fact, rule comp_min_basis_subset) next show "q ≠ 0" by (rule comp_min_basis_nonzero, fact) qed fact qed lemma comp_red_basis_is_red: "is_red (set (comp_red_basis xs)) f ⟷ is_red (set xs) f" proof assume "is_red (set (comp_red_basis xs)) f" then obtain x t where "x ∈ set (comp_red_basis xs)" and "t ∈ keys f" and "x ≠ 0" and "lt x adds⇩t t" by (rule is_red_addsE) from ‹x ∈ set (comp_red_basis xs)› obtain y where yin: "y ∈ set xs" and "y ≠ 0" and "lt y = lt x" by (rule comp_red_basis_lt) show "is_red (set xs) f" proof (rule is_red_addsI) from ‹lt x adds⇩t t› show "lt y adds⇩t t" unfolding ‹lt y = lt x› . qed fact+ next assume "is_red (set xs) f" then obtain x t where "x ∈ set xs" and "t ∈ keys f" and "x ≠ 0" and "lt x adds⇩t t" by (rule is_red_addsE) from ‹x ∈ set xs› ‹x ≠ 0› obtain y where yin: "y ∈ set (comp_red_basis xs)" and "lt y adds⇩t lt x" by (rule comp_red_basis_adds) show "is_red (set (comp_red_basis xs)) f" proof (rule is_red_addsI) from ‹lt y adds⇩t lt x› ‹lt x adds⇩t t› show "lt y adds⇩t t" by (rule adds_term_trans) next from yin show "y ≠ 0" by (rule comp_red_basis_nonzero) qed fact+ qed lemma comp_red_basis_is_auto_reduced: "is_auto_reduced (set (comp_red_basis xs))" unfolding is_auto_reduced_def remove_def proof (intro ballI) fix x assume xin: "x ∈ set (comp_red_basis xs)" show "¬ is_red (set (comp_red_basis xs) - {x}) x" unfolding comp_red_basis_def proof (rule comp_red_basis_aux_irred, simp_all, rule comp_min_basis_is_minimal_basis, rule comp_min_basis_distinct) from xin show "x ∈ set (comp_red_basis_aux (comp_min_basis xs) [])" unfolding comp_red_basis_def . qed qed lemma comp_red_basis_dgrad_p_set_le: assumes "dickson_grading d" shows "dgrad_p_set_le d (set (comp_red_basis xs)) (set xs)" proof - have "dgrad_p_set_le d (set (comp_red_basis xs)) (set (comp_min_basis xs) ∪ set [])" unfolding comp_red_basis_def using assms by (rule comp_red_basis_aux_dgrad_p_set_le) also have "... = set (comp_min_basis xs)" by simp also from comp_min_basis_subset have "dgrad_p_set_le d ... (set xs)" by (rule dgrad_p_set_le_subset) finally show ?thesis . qed subsection ‹Auto-Reduction and Monicity› definition comp_red_monic_basis :: "('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b::field) list" where "comp_red_monic_basis xs = map monic (comp_red_basis xs)" lemma set_comp_red_monic_basis: "set (comp_red_monic_basis xs) = monic ` (set (comp_red_basis xs))" by (simp add: comp_red_monic_basis_def) lemma comp_red_monic_basis_nonzero: assumes "p ∈ set (comp_red_monic_basis xs)" shows "p ≠ 0" proof - from assms obtain p' where p_def: "p = monic p'" and p': "p' ∈ set (comp_red_basis xs)" unfolding set_comp_red_monic_basis .. from p' have "p' ≠ 0" by (rule comp_red_basis_nonzero) thus ?thesis unfolding p_def monic_0_iff . qed lemma comp_red_monic_basis_is_monic_set: "is_monic_set (set (comp_red_monic_basis xs))" unfolding set_comp_red_monic_basis by (rule image_monic_is_monic_set) lemma pmdl_comp_red_monic_basis_subset: "pmdl (set (comp_red_monic_basis xs)) ⊆ pmdl (set xs)" unfolding set_comp_red_monic_basis pmdl_image_monic by (fact pmdl_comp_red_basis_subset) lemma comp_red_monic_basis_is_auto_reduced: "is_auto_reduced (set (comp_red_monic_basis xs))" unfolding set_comp_red_monic_basis by (rule image_monic_is_auto_reduced, rule comp_red_basis_is_auto_reduced) lemma comp_red_monic_basis_dgrad_p_set_le: assumes "dickson_grading d" shows "dgrad_p_set_le d (set (comp_red_monic_basis xs)) (set xs)" proof - have "dgrad_p_set_le d (monic ` (set (comp_red_basis xs))) (set (comp_red_basis xs))" by (simp add: dgrad_p_set_le_def, fact dgrad_set_le_refl) also from assms have "dgrad_p_set_le d ... (set xs)" by (rule comp_red_basis_dgrad_p_set_le) finally show ?thesis by (simp add: set_comp_red_monic_basis) qed end (* gd_term *) end (* theory *)
Theory Reduced_GB
section ‹Reduced Gr\"obner Bases› theory Reduced_GB imports Groebner_Bases Auto_Reduction begin lemma (in gd_term) GB_image_monic: "is_Groebner_basis (monic ` G) ⟷ is_Groebner_basis G" by (simp add: GB_alt_1) subsection ‹Definition and Uniqueness of Reduced Gr\"obner Bases› context ordered_term begin definition is_reduced_GB :: "('t ⇒⇩0 'b::field) set ⇒ bool" where "is_reduced_GB B ≡ is_Groebner_basis B ∧ is_auto_reduced B ∧ is_monic_set B ∧ 0 ∉ B" lemma reduced_GB_D1: assumes "is_reduced_GB G" shows "is_Groebner_basis G" using assms unfolding is_reduced_GB_def by simp lemma reduced_GB_D2: assumes "is_reduced_GB G" shows "is_auto_reduced G" using assms unfolding is_reduced_GB_def by simp lemma reduced_GB_D3: assumes "is_reduced_GB G" shows "is_monic_set G" using assms unfolding is_reduced_GB_def by simp lemma reduced_GB_D4: assumes "is_reduced_GB G" and "g ∈ G" shows "g ≠ 0" using assms unfolding is_reduced_GB_def by auto lemma reduced_GB_lc: assumes major: "is_reduced_GB G" and "g ∈ G" shows "lc g = 1" by (rule is_monic_setD, rule reduced_GB_D3, fact major, fact ‹g ∈ G›, rule reduced_GB_D4, fact major, fact ‹g ∈ G›) end (* ordered_term *) context gd_term begin lemma is_reduced_GB_subsetI: assumes Ared: "is_reduced_GB A" and BGB: "is_Groebner_basis B" and Bmon: "is_monic_set B" and *: "⋀a b. a ∈ A ⟹ b ∈ B ⟹ a ≠ 0 ⟹ b ≠ 0 ⟹ a - b ≠ 0 ⟹ lt (a - b) ∈ keys b ⟹ lt (a - b) ≺⇩t lt b ⟹ False" and id_eq: "pmdl A = pmdl B" shows "A ⊆ B" proof fix a assume "a ∈ A" have "a ≠ 0" by (rule reduced_GB_D4, fact Ared, fact ‹a ∈ A›) have lca: "lc a = 1" by (rule reduced_GB_lc, fact Ared, fact ‹a ∈ A›) have AGB: "is_Groebner_basis A" by (rule reduced_GB_D1, fact Ared) from ‹a ∈ A› have "a ∈ pmdl A" by (rule pmdl.span_base) also have "... = pmdl B" using id_eq by simp finally have "a ∈ pmdl B" . from BGB this ‹a ≠ 0› obtain b where "b ∈ B" and "b ≠ 0" and baddsa: "lt b adds⇩t lt a" by (rule GB_adds_lt) from Bmon this(1) this(2) have lcb: "lc b = 1" by (rule is_monic_setD) from ‹b ∈ B› have "b ∈ pmdl B" by (rule pmdl.span_base) also have "... = pmdl A" using id_eq by simp finally have "b ∈ pmdl A" . have lt_eq: "lt b = lt a" proof (rule ccontr) assume "lt b ≠ lt a" from AGB ‹b ∈ pmdl A› ‹b ≠ 0› obtain a' where "a' ∈ A" and "a' ≠ 0" and a'addsb: "lt a' adds⇩t lt b" by (rule GB_adds_lt) have a'addsa: "lt a' adds⇩t lt a" by (rule adds_term_trans, fact a'addsb, fact baddsa) have "lt a' ≠ lt a" proof assume "lt a' = lt a" hence aaddsa': "lt a adds⇩t lt a'" by (simp add: adds_term_refl) have "lt a adds⇩t lt b" by (rule adds_term_trans, fact aaddsa', fact a'addsb) have "lt a = lt b" by (rule adds_term_antisym, fact+) with ‹lt b ≠ lt a› show False by simp qed hence "a' ≠ a" by auto with ‹a' ∈ A› have "a' ∈ A - {a}" by blast have is_red: "is_red (A - {a}) a" by (intro is_red_addsI, fact, fact, rule lt_in_keys, fact+) have "¬ is_red (A - {a}) a" by (rule is_auto_reducedD, rule reduced_GB_D2, fact Ared, fact+) from this is_red show False .. qed have "a - b = 0" proof (rule ccontr) let ?c = "a - b" assume "?c ≠ 0" have "?c ∈ pmdl A" by (rule pmdl.span_diff, fact+) also have "... = pmdl B" using id_eq by simp finally have "?c ∈ pmdl B" . from ‹b ≠ 0› have "- b ≠ 0" by simp have "lt (-b) = lt a" unfolding lt_uminus by fact have "lc (-b) = - lc a" unfolding lc_uminus lca lcb .. from ‹?c ≠ 0› have "a + (-b) ≠ 0" by simp have "lt ?c ∈ keys ?c" by (rule lt_in_keys, fact) have "keys ?c ⊆ (keys a ∪ keys b)" by (fact keys_minus) with ‹lt ?c ∈ keys ?c› have "lt ?c ∈ keys a ∨ lt ?c ∈ keys b" by auto thus False proof assume "lt ?c ∈ keys a" from AGB ‹?c ∈ pmdl A› ‹?c ≠ 0› obtain a' where "a' ∈ A" and "a' ≠ 0" and a'addsc: "lt a' adds⇩t lt ?c" by (rule GB_adds_lt) from a'addsc have "lt a' ≼⇩t lt ?c" by (rule ord_adds_term) also have "... = lt (a + (- b))" by simp also have "... ≺⇩t lt a" by (rule lt_plus_lessI, fact+) finally have "lt a' ≺⇩t lt a" . hence "lt a' ≠ lt a" by simp hence "a' ≠ a" by auto with ‹a' ∈ A› have "a' ∈ A - {a}" by blast have is_red: "is_red (A - {a}) a" by (intro is_red_addsI, fact, fact, fact+) have "¬ is_red (A - {a}) a" by (rule is_auto_reducedD, rule reduced_GB_D2, fact Ared, fact+) from this is_red show False .. next assume "lt ?c ∈ keys b" with ‹a ∈ A› ‹b ∈ B› ‹a ≠ 0› ‹b ≠ 0› ‹?c ≠ 0› show False proof (rule *) have "lt ?c = lt ((- b) + a)" by simp also have "... ≺⇩t lt (-b)" proof (rule lt_plus_lessI) from ‹?c ≠ 0› show "-b + a ≠ 0" by simp next from ‹lt (-b) = lt a› show "lt a = lt (-b)" by simp next from ‹lc (-b) = - lc a› show "lc a = - lc (-b)" by simp qed finally show "lt ?c ≺⇩t lt b" unfolding lt_uminus . qed qed qed hence "a = b" by simp with ‹b ∈ B› show "a ∈ B" by simp qed lemma is_reduced_GB_unique': assumes Ared: "is_reduced_GB A" and Bred: "is_reduced_GB B" and id_eq: "pmdl A = pmdl B" shows "A ⊆ B" proof - from Bred have BGB: "is_Groebner_basis B" by (rule reduced_GB_D1) with assms(1) show ?thesis proof (rule is_reduced_GB_subsetI) from Bred show "is_monic_set B" by (rule reduced_GB_D3) next fix a b :: "'t ⇒⇩0 'b" let ?c = "a - b" assume "a ∈ A" and "b ∈ B" and "a ≠ 0" and "b ≠ 0" and "?c ≠ 0" and "lt ?c ∈ keys b" and "lt ?c ≺⇩t lt b" from ‹a ∈ A› have "a ∈ pmdl B" by (simp only: id_eq[symmetric], rule pmdl.span_base) moreover from ‹b ∈ B› have "b ∈ pmdl B" by (rule pmdl.span_base) ultimately have "?c ∈ pmdl B" by (rule pmdl.span_diff) from BGB this ‹?c ≠ 0› obtain b' where "b' ∈ B" and "b' ≠ 0" and b'addsc: "lt b' adds⇩t lt ?c" by (rule GB_adds_lt) from b'addsc have "lt b' ≼⇩t lt ?c" by (rule ord_adds_term) also have "... ≺⇩t lt b" by fact finally have "lt b' ≺⇩t lt b" unfolding lt_uminus . hence "lt b' ≠ lt b" by simp hence "b' ≠ b" by auto with ‹b' ∈ B› have "b' ∈ B - {b}" by blast have is_red: "is_red (B - {b}) b" by (intro is_red_addsI, fact, fact, fact+) have "¬ is_red (B - {b}) b" by (rule is_auto_reducedD, rule reduced_GB_D2, fact Bred, fact+) from this is_red show False .. qed fact qed theorem is_reduced_GB_unique: assumes Ared: "is_reduced_GB A" and Bred: "is_reduced_GB B" and id_eq: "pmdl A = pmdl B" shows "A = B" proof from assms show "A ⊆ B" by (rule is_reduced_GB_unique') next from Bred Ared id_eq[symmetric] show "B ⊆ A" by (rule is_reduced_GB_unique') qed subsection ‹Computing Reduced Gr\"obner Bases by Auto-Reduction› subsubsection ‹Minimal Bases› lemma minimal_basis_is_reduced_GB: assumes "is_minimal_basis B" and "is_monic_set B" and "is_reduced_GB G" and "G ⊆ B" and "pmdl B = pmdl G" shows "B = G" using _ assms(3) assms(5) proof (rule is_reduced_GB_unique) from assms(3) have "is_Groebner_basis G" by (rule reduced_GB_D1) show "is_reduced_GB B" unfolding is_reduced_GB_def proof (intro conjI) show "0 ∉ B" proof assume "0 ∈ B" with assms(1) have "0 ≠ (0::'t ⇒⇩0 'b)" by (rule is_minimal_basisD1) thus False by simp qed next from ‹is_Groebner_basis G› assms(4) assms(5) show "is_Groebner_basis B" by (rule GB_subset) next show "is_auto_reduced B" unfolding is_auto_reduced_def proof (intro ballI notI) fix b assume "b ∈ B" with assms(1) have "b ≠ 0" by (rule is_minimal_basisD1) assume "is_red (B - {b}) b" then obtain f where "f ∈ B - {b}" and "is_red {f} b" by (rule is_red_singletonI) from this(1) have "f ∈ B" and "f ≠ b" by simp_all from assms(1) ‹f ∈ B› have "f ≠ 0" by (rule is_minimal_basisD1) from ‹f ∈ B› have "f ∈ pmdl B" by (rule pmdl.span_base) hence "f ∈ pmdl G" by (simp only: assms(5)) from ‹is_Groebner_basis G› this ‹f ≠ 0› obtain g where "g ∈ G" and "g ≠ 0" and "lt g adds⇩t lt f" by (rule GB_adds_lt) from ‹g ∈ G› ‹G ⊆ B› have "g ∈ B" .. have "g = f" proof (rule ccontr) assume "g ≠ f" with assms(1) ‹g ∈ B› ‹f ∈ B› have "¬ lt g adds⇩t lt f" by (rule is_minimal_basisD2) from this ‹lt g adds⇩t lt f› show False .. qed with ‹g ∈ G› have "f ∈ G" by simp with ‹f ∈ B - {b}› ‹is_red {f} b› have red: "is_red (G - {b}) b" by (meson Diff_iff is_red_singletonD) from ‹b ∈ B› have "b ∈ pmdl B" by (rule pmdl.span_base) hence "b ∈ pmdl G" by (simp only: assms(5)) from ‹is_Groebner_basis G› this ‹b ≠ 0› obtain g' where "g' ∈ G" and "g' ≠ 0" and "lt g' adds⇩t lt b" by (rule GB_adds_lt) from ‹g' ∈ G› ‹G ⊆ B› have "g' ∈ B" .. have "g' = b" proof (rule ccontr) assume "g' ≠ b" with assms(1) ‹g' ∈ B› ‹b ∈ B› have "¬ lt g' adds⇩t lt b" by (rule is_minimal_basisD2) from this ‹lt g' adds⇩t lt b› show False .. qed with ‹g' ∈ G› have "b ∈ G" by simp from assms(3) have "is_auto_reduced G" by (rule reduced_GB_D2) from this ‹b ∈ G› have "¬ is_red (G - {b}) b" by (rule is_auto_reducedD) from this red show False .. qed qed fact qed subsubsection ‹Computing Minimal Bases› lemma comp_min_basis_pmdl: assumes "is_Groebner_basis (set xs)" shows "pmdl (set (comp_min_basis xs)) = pmdl (set xs)" (is "pmdl (set ?ys) = _") using finite_set proof (rule pmdl_eqI_adds_lt_finite) from comp_min_basis_subset show *: "pmdl (set ?ys) ⊆ pmdl (set xs)" by (rule pmdl.span_mono) next fix f assume "f ∈ pmdl (set xs)" and "f ≠ 0" with assms obtain g where "g ∈ set xs" and "g ≠ 0" and 1: "lt g adds⇩t lt f" by (rule GB_adds_lt) from this(1, 2) obtain g' where "g' ∈ set ?ys" and 2: "lt g' adds⇩t lt g" by (rule comp_min_basis_adds) note this(1) moreover from this have "g' ≠ 0" by (rule comp_min_basis_nonzero) moreover from 2 1 have "lt g' adds⇩t lt f" by (rule adds_term_trans) ultimately show "∃g∈set ?ys. g ≠ 0 ∧ lt g adds⇩t lt f" by blast qed lemma comp_min_basis_GB: assumes "is_Groebner_basis (set xs)" shows "is_Groebner_basis (set (comp_min_basis xs))" (is "is_Groebner_basis (set ?ys)") unfolding GB_alt_2_finite[OF finite_set] proof (intro ballI impI) fix f assume "f ∈ pmdl (set ?ys)" also from assms have "… = pmdl (set xs)" by (rule comp_min_basis_pmdl) finally have "f ∈ pmdl (set xs)" . moreover assume "f ≠ 0" ultimately have "is_red (set xs) f" using assms unfolding GB_alt_2_finite[OF finite_set] by blast thus "is_red (set ?ys) f" by (rule comp_min_basis_is_red) qed subsubsection ‹Computing Reduced Bases› lemma comp_red_basis_pmdl: assumes "is_Groebner_basis (set xs)" shows "pmdl (set (comp_red_basis xs)) = pmdl (set xs)" proof (rule, fact pmdl_comp_red_basis_subset, rule) fix f assume "f ∈ pmdl (set xs)" show "f ∈ pmdl (set (comp_red_basis xs))" proof (cases "f = 0") case True show ?thesis unfolding True by (rule pmdl.span_zero) next case False let ?xs = "comp_red_basis xs" have "(red (set ?xs))⇧*⇧* f 0" proof (rule is_red_implies_0_red_finite, fact finite_set, fact pmdl_comp_red_basis_subset) fix q assume "q ≠ 0" and "q ∈ pmdl (set xs)" with assms have "is_red (set xs) q" by (rule GB_imp_reducibility) thus "is_red (set (comp_red_basis xs)) q" unfolding comp_red_basis_is_red . qed fact thus ?thesis by (rule red_rtranclp_0_in_pmdl) qed qed lemma comp_red_basis_GB: assumes "is_Groebner_basis (set xs)" shows "is_Groebner_basis (set (comp_red_basis xs))" unfolding GB_alt_2_finite[OF finite_set] proof (intro ballI impI) fix f assume fin: "f ∈ pmdl (set (comp_red_basis xs))" hence "f ∈ pmdl (set xs)" unfolding comp_red_basis_pmdl[OF assms] . assume "f ≠ 0" from assms ‹f ≠ 0› ‹f ∈ pmdl (set xs)› show "is_red (set (comp_red_basis xs)) f" by (simp add: comp_red_basis_is_red GB_alt_2_finite) qed subsubsection ‹Computing Reduced Gr\"obner Bases› lemma comp_red_monic_basis_pmdl: assumes "is_Groebner_basis (set xs)" shows "pmdl (set (comp_red_monic_basis xs)) = pmdl (set xs)" unfolding set_comp_red_monic_basis pmdl_image_monic comp_red_basis_pmdl[OF assms] .. lemma comp_red_monic_basis_GB: assumes "is_Groebner_basis (set xs)" shows "is_Groebner_basis (set (comp_red_monic_basis xs))" unfolding set_comp_red_monic_basis GB_image_monic using assms by (rule comp_red_basis_GB) lemma comp_red_monic_basis_is_reduced_GB: assumes "is_Groebner_basis (set xs)" shows "is_reduced_GB (set (comp_red_monic_basis xs))" unfolding is_reduced_GB_def proof (intro conjI, rule comp_red_monic_basis_GB, fact assms, rule comp_red_monic_basis_is_auto_reduced, rule comp_red_monic_basis_is_monic_set, intro notI) assume "0 ∈ set (comp_red_monic_basis xs)" hence "0 ≠ (0::'t ⇒⇩0 'b)" by (rule comp_red_monic_basis_nonzero) thus False by simp qed lemma ex_finite_reduced_GB_dgrad_p_set: assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m" obtains G where "G ⊆ dgrad_p_set d m" and "finite G" and "is_reduced_GB G" and "pmdl G = pmdl F" proof - from assms obtain G0 where G0_sub: "G0 ⊆ dgrad_p_set d m" and fin: "finite G0" and gb: "is_Groebner_basis G0" and pid: "pmdl G0 = pmdl F" by (rule ex_finite_GB_dgrad_p_set) from fin obtain xs where set: "G0 = set xs" using finite_list by blast let ?G = "set (comp_red_monic_basis xs)" show ?thesis proof from assms(1) have "dgrad_p_set_le d (set (comp_red_monic_basis xs)) G0" unfolding set by (rule comp_red_monic_basis_dgrad_p_set_le) from this G0_sub show "set (comp_red_monic_basis xs) ⊆ dgrad_p_set d m" by (rule dgrad_p_set_le_dgrad_p_set) next from gb show rgb: "is_reduced_GB ?G" unfolding set by (rule comp_red_monic_basis_is_reduced_GB) next from gb show "pmdl ?G = pmdl F" unfolding set pid[symmetric] by (rule comp_red_monic_basis_pmdl) qed (fact finite_set) qed theorem ex_unique_reduced_GB_dgrad_p_set: assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m" shows "∃!G. G ⊆ dgrad_p_set d m ∧ finite G ∧ is_reduced_GB G ∧ pmdl G = pmdl F" proof - from assms obtain G where "G ⊆ dgrad_p_set d m" and "finite G" and "is_reduced_GB G" and G: "pmdl G = pmdl F" by (rule ex_finite_reduced_GB_dgrad_p_set) hence "G ⊆ dgrad_p_set d m ∧ finite G ∧ is_reduced_GB G ∧ pmdl G = pmdl F" by simp thus ?thesis proof (rule ex1I) fix G' assume "G' ⊆ dgrad_p_set d m ∧ finite G' ∧ is_reduced_GB G' ∧ pmdl G' = pmdl F" hence "is_reduced_GB G'" and G': "pmdl G' = pmdl F" by simp_all note this(1) ‹is_reduced_GB G› moreover have "pmdl G' = pmdl G" by (simp only: G G') ultimately show "G' = G" by (rule is_reduced_GB_unique) qed qed corollary ex_unique_reduced_GB_dgrad_p_set': assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m" shows "∃!G. finite G ∧ is_reduced_GB G ∧ pmdl G = pmdl F" proof - from assms obtain G where "G ⊆ dgrad_p_set d m" and "finite G" and "is_reduced_GB G" and G: "pmdl G = pmdl F" by (rule ex_finite_reduced_GB_dgrad_p_set) hence "finite G ∧ is_reduced_GB G ∧ pmdl G = pmdl F" by simp thus ?thesis proof (rule ex1I) fix G' assume "finite G' ∧ is_reduced_GB G' ∧ pmdl G' = pmdl F" hence "is_reduced_GB G'" and G': "pmdl G' = pmdl F" by simp_all note this(1) ‹is_reduced_GB G› moreover have "pmdl G' = pmdl G" by (simp only: G G') ultimately show "G' = G" by (rule is_reduced_GB_unique) qed qed definition reduced_GB :: "('t ⇒⇩0 'b) set ⇒ ('t ⇒⇩0 'b::field) set" where "reduced_GB B = (THE G. finite G ∧ is_reduced_GB G ∧ pmdl G = pmdl B)" text ‹@{const reduced_GB} returns the unique reduced Gr\"obner basis of the given set, provided its Dickson grading is bounded. Combining @{const comp_red_monic_basis} with any function for computing Gr\"obner bases, e.\,g. ‹gb› from theory "Buchberger", makes @{const reduced_GB} computable.› lemma finite_reduced_GB_dgrad_p_set: assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m" shows "finite (reduced_GB F)" unfolding reduced_GB_def by (rule the1I2, rule ex_unique_reduced_GB_dgrad_p_set', fact, fact, fact, elim conjE) lemma reduced_GB_is_reduced_GB_dgrad_p_set: assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m" shows "is_reduced_GB (reduced_GB F)" unfolding reduced_GB_def by (rule the1I2, rule ex_unique_reduced_GB_dgrad_p_set', fact, fact, fact, elim conjE) lemma reduced_GB_is_GB_dgrad_p_set: assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m" shows "is_Groebner_basis (reduced_GB F)" proof - from assms have "is_reduced_GB (reduced_GB F)" by (rule reduced_GB_is_reduced_GB_dgrad_p_set) thus ?thesis unfolding is_reduced_GB_def .. qed lemma reduced_GB_is_auto_reduced_dgrad_p_set: assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m" shows "is_auto_reduced (reduced_GB F)" proof - from assms have "is_reduced_GB (reduced_GB F)" by (rule reduced_GB_is_reduced_GB_dgrad_p_set) thus ?thesis unfolding is_reduced_GB_def by simp qed lemma reduced_GB_is_monic_set_dgrad_p_set: assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m" shows "is_monic_set (reduced_GB F)" proof - from assms have "is_reduced_GB (reduced_GB F)" by (rule reduced_GB_is_reduced_GB_dgrad_p_set) thus ?thesis unfolding is_reduced_GB_def by simp qed lemma reduced_GB_nonzero_dgrad_p_set: assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m" shows "0 ∉ reduced_GB F" proof - from assms have "is_reduced_GB (reduced_GB F)" by (rule reduced_GB_is_reduced_GB_dgrad_p_set) thus ?thesis unfolding is_reduced_GB_def by simp qed lemma reduced_GB_pmdl_dgrad_p_set: assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m" shows "pmdl (reduced_GB F) = pmdl F" unfolding reduced_GB_def by (rule the1I2, rule ex_unique_reduced_GB_dgrad_p_set', fact, fact, fact, elim conjE) lemma reduced_GB_unique_dgrad_p_set: assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m" and "is_reduced_GB G" and "pmdl G = pmdl F" shows "reduced_GB F = G" by (rule is_reduced_GB_unique, rule reduced_GB_is_reduced_GB_dgrad_p_set, fact+, simp only: reduced_GB_pmdl_dgrad_p_set[OF assms(1, 2, 3)] assms(5)) lemma reduced_GB_dgrad_p_set: assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m" shows "reduced_GB F ⊆ dgrad_p_set d m" proof - from assms obtain G where G: "G ⊆ dgrad_p_set d m" and "is_reduced_GB G" and "pmdl G = pmdl F" by (rule ex_finite_reduced_GB_dgrad_p_set) from assms this(2, 3) have "reduced_GB F = G" by (rule reduced_GB_unique_dgrad_p_set) with G show ?thesis by simp qed lemma reduced_GB_unique: assumes "finite G" and "is_reduced_GB G" and "pmdl G = pmdl F" shows "reduced_GB F = G" proof - from assms have "finite G ∧ is_reduced_GB G ∧ pmdl G = pmdl F" by simp thus ?thesis unfolding reduced_GB_def proof (rule the_equality) fix G' assume "finite G' ∧ is_reduced_GB G' ∧ pmdl G' = pmdl F" hence "is_reduced_GB G'" and eq: "pmdl G' = pmdl F" by simp_all note this(1) moreover note assms(2) moreover have "pmdl G' = pmdl G" by (simp only: assms(3) eq) ultimately show "G' = G" by (rule is_reduced_GB_unique) qed qed lemma is_reduced_GB_empty: "is_reduced_GB {}" by (simp add: is_reduced_GB_def is_Groebner_basis_empty is_monic_set_def is_auto_reduced_def) lemma is_reduced_GB_singleton: "is_reduced_GB {f} ⟷ lc f = 1" proof assume "is_reduced_GB {f}" hence "is_monic_set {f}" and "f ≠ 0" by (rule reduced_GB_D3, rule reduced_GB_D4) simp from this(1) _ this(2) show "lc f = 1" by (rule is_monic_setD) simp next assume "lc f = 1" moreover from this have "f ≠ 0" by auto ultimately show "is_reduced_GB {f}" by (simp add: is_reduced_GB_def is_Groebner_basis_singleton is_monic_set_def is_auto_reduced_def not_is_red_empty) qed lemma reduced_GB_empty: "reduced_GB {} = {}" using finite.emptyI is_reduced_GB_empty refl by (rule reduced_GB_unique) lemma reduced_GB_singleton: "reduced_GB {f} = (if f = 0 then {} else {monic f})" proof (cases "f = 0") case True from finite.emptyI is_reduced_GB_empty have "reduced_GB {f} = {}" by (rule reduced_GB_unique) (simp add: True flip: pmdl.span_Diff_zero[of "{0}"]) with True show ?thesis by simp next case False have "reduced_GB {f} = {monic f}" proof (rule reduced_GB_unique) from False have "lc f ≠ 0" by (rule lc_not_0) thus "is_reduced_GB {monic f}" by (simp add: is_reduced_GB_singleton monic_def) next have "pmdl {monic f} = pmdl (monic ` {f})" by simp also have "… = pmdl {f}" by (fact pmdl_image_monic) finally show "pmdl {monic f} = pmdl {f}" . qed simp with False show ?thesis by simp qed lemma ex_unique_reduced_GB_finite: "finite F ⟹ (∃!G. finite G ∧ is_reduced_GB G ∧ pmdl G = pmdl F)" by (rule ex_unique_reduced_GB_dgrad_p_set', rule dickson_grading_dgrad_dummy, erule finite_imp_finite_component_Keys, erule dgrad_p_set_exhaust_expl) lemma finite_reduced_GB_finite: "finite F ⟹ finite (reduced_GB F)" by (rule finite_reduced_GB_dgrad_p_set, rule dickson_grading_dgrad_dummy, erule finite_imp_finite_component_Keys, erule dgrad_p_set_exhaust_expl) lemma reduced_GB_is_reduced_GB_finite: "finite F ⟹ is_reduced_GB (reduced_GB F)" by (rule reduced_GB_is_reduced_GB_dgrad_p_set, rule dickson_grading_dgrad_dummy, erule finite_imp_finite_component_Keys, erule dgrad_p_set_exhaust_expl) lemma reduced_GB_is_GB_finite: "finite F ⟹ is_Groebner_basis (reduced_GB F)" by (rule reduced_GB_is_GB_dgrad_p_set, rule dickson_grading_dgrad_dummy, erule finite_imp_finite_component_Keys, erule dgrad_p_set_exhaust_expl) lemma reduced_GB_is_auto_reduced_finite: "finite F ⟹ is_auto_reduced (reduced_GB F)" by (rule reduced_GB_is_auto_reduced_dgrad_p_set, rule dickson_grading_dgrad_dummy, erule finite_imp_finite_component_Keys, erule dgrad_p_set_exhaust_expl) lemma reduced_GB_is_monic_set_finite: "finite F ⟹ is_monic_set (reduced_GB F)" by (rule reduced_GB_is_monic_set_dgrad_p_set, rule dickson_grading_dgrad_dummy, erule finite_imp_finite_component_Keys, erule dgrad_p_set_exhaust_expl) lemma reduced_GB_nonzero_finite: "finite F ⟹ 0 ∉ reduced_GB F" by (rule reduced_GB_nonzero_dgrad_p_set, rule dickson_grading_dgrad_dummy, erule finite_imp_finite_component_Keys, erule dgrad_p_set_exhaust_expl) lemma reduced_GB_pmdl_finite: "finite F ⟹ pmdl (reduced_GB F) = pmdl F" by (rule reduced_GB_pmdl_dgrad_p_set, rule dickson_grading_dgrad_dummy, erule finite_imp_finite_component_Keys, erule dgrad_p_set_exhaust_expl) lemma reduced_GB_unique_finite: "finite F ⟹ is_reduced_GB G ⟹ pmdl G = pmdl F ⟹ reduced_GB F = G" by (rule reduced_GB_unique_dgrad_p_set, rule dickson_grading_dgrad_dummy, erule finite_imp_finite_component_Keys, erule dgrad_p_set_exhaust_expl) end (* gd_term *) subsubsection ‹Properties of the Reduced Gr\"obner Basis of an Ideal› context gd_powerprod begin lemma ideal_eq_UNIV_iff_reduced_GB_eq_one_dgrad_p_set: assumes "dickson_grading d" and "F ⊆ punit.dgrad_p_set d m" shows "ideal F = UNIV ⟷ punit.reduced_GB F = {1}" proof - have fin: "finite (local.punit.component_of_term ` Keys F)" by simp show ?thesis proof assume "ideal F = UNIV" from assms(1) fin assms(2) show "punit.reduced_GB F = {1}" proof (rule punit.reduced_GB_unique_dgrad_p_set) show "punit.is_reduced_GB {1}" unfolding punit.is_reduced_GB_def proof (intro conjI, fact punit.is_Groebner_basis_singleton) show "punit.is_auto_reduced {1}" unfolding punit.is_auto_reduced_def by (rule ballI, simp add: remove_def punit.not_is_red_empty) next show "punit.is_monic_set {1}" by (rule punit.is_monic_setI, simp del: single_one add: single_one[symmetric]) qed simp next have "punit.pmdl {1} = ideal {1}" by simp also have "... = ideal F" proof (simp only: ‹ideal F = UNIV› ideal_eq_UNIV_iff_contains_one) have "1 ∈ {1}" .. with module_times show "1 ∈ ideal {1}" by (rule module.span_base) qed also have "... = punit.pmdl F" by simp finally show "punit.pmdl {1} = punit.pmdl F" . qed next assume "punit.reduced_GB F = {1}" hence "1 ∈ punit.reduced_GB F" by simp hence "1 ∈ punit.pmdl (punit.reduced_GB F)" by (rule punit.pmdl.span_base) also from assms(1) fin assms(2) have "... = punit.pmdl F" by (rule punit.reduced_GB_pmdl_dgrad_p_set) finally show "ideal F = UNIV" by (simp add: ideal_eq_UNIV_iff_contains_one) qed qed lemmas ideal_eq_UNIV_iff_reduced_GB_eq_one_finite = ideal_eq_UNIV_iff_reduced_GB_eq_one_dgrad_p_set[OF dickson_grading_dgrad_dummy punit.dgrad_p_set_exhaust_expl] end (* gd_powerprod *) subsubsection ‹Context @{locale od_term}› context od_term begin lemmas ex_unique_reduced_GB = ex_unique_reduced_GB_dgrad_p_set'[OF dickson_grading_zero _ subset_dgrad_p_set_zero] lemmas finite_reduced_GB = finite_reduced_GB_dgrad_p_set[OF dickson_grading_zero _ subset_dgrad_p_set_zero] lemmas reduced_GB_is_reduced_GB = reduced_GB_is_reduced_GB_dgrad_p_set[OF dickson_grading_zero _ subset_dgrad_p_set_zero] lemmas reduced_GB_is_GB = reduced_GB_is_GB_dgrad_p_set[OF dickson_grading_zero _ subset_dgrad_p_set_zero] lemmas reduced_GB_is_auto_reduced = reduced_GB_is_auto_reduced_dgrad_p_set[OF dickson_grading_zero _ subset_dgrad_p_set_zero] lemmas reduced_GB_is_monic_set = reduced_GB_is_monic_set_dgrad_p_set[OF dickson_grading_zero _ subset_dgrad_p_set_zero] lemmas reduced_GB_nonzero = reduced_GB_nonzero_dgrad_p_set[OF dickson_grading_zero _ subset_dgrad_p_set_zero] lemmas reduced_GB_pmdl = reduced_GB_pmdl_dgrad_p_set[OF dickson_grading_zero _ subset_dgrad_p_set_zero] lemmas reduced_GB_unique = reduced_GB_unique_dgrad_p_set[OF dickson_grading_zero _ subset_dgrad_p_set_zero] end (* od_term *) end (* theory *)
Theory Reduced_GB_Examples
(* Author: Alexander Maletzky *) section ‹Sample Computations of Reduced Gr\"obner Bases› theory Reduced_GB_Examples imports Buchberger Reduced_GB Polynomials.MPoly_Type_Class_OAlist Code_Target_Rat begin context gd_term begin definition rgb :: "('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b::field) list" where "rgb bs = comp_red_monic_basis (map fst (gb (map (λb. (b, ())) bs) ()))" definition rgb_punit :: "('a ⇒⇩0 'b) list ⇒ ('a ⇒⇩0 'b::field) list" where "rgb_punit bs = punit.comp_red_monic_basis (map fst (gb_punit (map (λb. (b, ())) bs) ()))" lemma compute_trd_aux [code]: "trd_aux fs p r = (if is_zero p then r else case find_adds fs (lt p) of None ⇒ trd_aux fs (tail p) (plus_monomial_less r (lc p) (lt p)) | Some f ⇒ trd_aux fs (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f)) r )" by (simp only: trd_aux.simps[of fs p r] plus_monomial_less_def is_zero_def) end text ‹We only consider scalar polynomials here, but vector-polynomials could be handled, too.› global_interpretation punit': gd_powerprod "ord_pp_punit cmp_term" "ord_pp_strict_punit cmp_term" rewrites "punit.adds_term = (adds)" and "punit.pp_of_term = (λx. x)" and "punit.component_of_term = (λ_. ())" and "punit.monom_mult = monom_mult_punit" and "punit.mult_scalar = mult_scalar_punit" and "punit'.punit.min_term = min_term_punit" and "punit'.punit.lt = lt_punit cmp_term" and "punit'.punit.lc = lc_punit cmp_term" and "punit'.punit.tail = tail_punit cmp_term" and "punit'.punit.ord_p = ord_p_punit cmp_term" and "punit'.punit.ord_strict_p = ord_strict_p_punit cmp_term" for cmp_term :: "('a::nat, 'b::{nat,add_wellorder}) pp nat_term_order" defines find_adds_punit = punit'.punit.find_adds and trd_aux_punit = punit'.punit.trd_aux and trd_punit = punit'.punit.trd and spoly_punit = punit'.punit.spoly and count_const_lt_components_punit = punit'.punit.count_const_lt_components and count_rem_components_punit = punit'.punit.count_rem_components and const_lt_component_punit = punit'.punit.const_lt_component and full_gb_punit = punit'.punit.full_gb and add_pairs_single_sorted_punit = punit'.punit.add_pairs_single_sorted and add_pairs_punit = punit'.punit.add_pairs and canon_pair_order_aux_punit = punit'.punit.canon_pair_order_aux and canon_basis_order_punit = punit'.punit.canon_basis_order and new_pairs_sorted_punit = punit'.punit.new_pairs_sorted and product_crit_punit = punit'.punit.product_crit and chain_ncrit_punit = punit'.punit.chain_ncrit and chain_ocrit_punit = punit'.punit.chain_ocrit and apply_icrit_punit = punit'.punit.apply_icrit and apply_ncrit_punit = punit'.punit.apply_ncrit and apply_ocrit_punit = punit'.punit.apply_ocrit and trdsp_punit = punit'.punit.trdsp and gb_sel_punit = punit'.punit.gb_sel and gb_red_aux_punit = punit'.punit.gb_red_aux and gb_red_punit = punit'.punit.gb_red and gb_aux_punit = punit'.punit.gb_aux_punit and gb_punit = punit'.punit.gb_punit ―‹Faster, because incorporates product criterion.› and comp_min_basis_punit = punit'.punit.comp_min_basis and comp_red_basis_aux_punit = punit'.punit.comp_red_basis_aux and comp_red_basis_punit = punit'.punit.comp_red_basis and monic_punit = punit'.punit.monic and comp_red_monic_basis_punit = punit'.punit.comp_red_monic_basis and rgb_punit = punit'.punit.rgb_punit subgoal by (fact gd_powerprod_ord_pp_punit) subgoal by (fact punit_adds_term) subgoal by (simp add: id_def) subgoal by (fact punit_component_of_term) subgoal by (simp only: monom_mult_punit_def) subgoal by (simp only: mult_scalar_punit_def) subgoal using min_term_punit_def by fastforce subgoal by (simp only: lt_punit_def ord_pp_punit_alt) subgoal by (simp only: lc_punit_def ord_pp_punit_alt) subgoal by (simp only: tail_punit_def ord_pp_punit_alt) subgoal by (simp only: ord_p_punit_def ord_pp_strict_punit_alt) subgoal by (simp only: ord_strict_p_punit_def ord_pp_strict_punit_alt) done lemma compute_spoly_punit [code]: "spoly_punit to p q = (let t1 = lt_punit to p; t2 = lt_punit to q; l = lcs t1 t2 in (monom_mult_punit (1 / lc_punit to p) (l - t1) p) - (monom_mult_punit (1 / lc_punit to q) (l - t2) q))" by (simp add: punit'.punit.spoly_def Let_def punit'.punit.lc_def) lemma compute_trd_punit [code]: "trd_punit to fs p = trd_aux_punit to fs p (change_ord to 0)" by (simp only: punit'.punit.trd_def change_ord_def) experiment begin interpretation trivariate⇩0_rat . lemma "rgb_punit DRLEX [ X ^ 3 - X * Y * Z⇧2, Y⇧2 * Z - 1 ] = [ X ^ 3 * Y - X * Z, - (X ^ 3) + X * Y * Z⇧2, Y⇧2 * Z - 1, - (X * Z ^ 3) + X ^ 5 ]" by eval lemma "rgb_punit DRLEX [ X⇧2 + Y⇧2 + Z⇧2 - 1, X * Y - Z - 1, Y⇧2 + X, Z⇧2 + X ] = [ 1 ]" by eval text ‹Note: The above computations have been cross-checked with Mathematica 11.1.› end end (* theory *)
Theory Macaulay_Matrix
(* Author: Alexander Maletzky *) section ‹Macaulay Matrices› theory Macaulay_Matrix imports More_MPoly_Type_Class Jordan_Normal_Form.Gauss_Jordan_Elimination begin text ‹We build upon vectors and matrices represented by dimension and characteristic function, because later on we need to quantify the dimensions of certain matrices existentially. This is not possible (at least not easily possible) with a type-based approach, as in HOL-Multivariate Analysis.› subsection ‹More about Vectors› lemma vec_of_list_alt: "vec_of_list xs = vec (length xs) (nth xs)" by (transfer, rule refl) lemma vec_cong: assumes "n = m" and "⋀i. i < m ⟹ f i = g i" shows "vec n f = vec m g" using assms by auto lemma scalar_prod_comm: assumes "dim_vec v = dim_vec w" shows "v ∙ w = w ∙ (v::'a::comm_semiring_0 vec)" by (simp add: scalar_prod_def assms, rule sum.cong, rule refl, simp only: ac_simps) lemma vec_scalar_mult_fun: "vec n (λx. c * f x) = c ⋅⇩v vec n f" by (simp add: smult_vec_def, rule vec_cong, rule refl, simp) definition mult_vec_mat :: "'a vec ⇒ 'a :: semiring_0 mat ⇒ 'a vec" (infixl "⇩v*" 70) where "v ⇩v* A ≡ vec (dim_col A) (λj. v ∙ col A j)" definition resize_vec :: "nat ⇒ 'a vec ⇒ 'a vec" where "resize_vec n v = vec n (vec_index v)" lemma dim_resize_vec[simp]: "dim_vec (resize_vec n v) = n" by (simp add: resize_vec_def) lemma resize_vec_carrier: "resize_vec n v ∈ carrier_vec n" by (simp add: carrier_dim_vec) lemma resize_vec_dim[simp]: "resize_vec (dim_vec v) v = v" by (simp add: resize_vec_def eq_vecI) lemma resize_vec_index: assumes "i < n" shows "resize_vec n v $ i = v $ i" using assms by (simp add: resize_vec_def) lemma mult_mat_vec_resize: "v ⇩v* A = (resize_vec (dim_row A) v) ⇩v* A" by (simp add: mult_vec_mat_def scalar_prod_def, rule arg_cong2[of _ _ _ _ vec], rule, rule, rule sum.cong, rule, simp add: resize_vec_index) lemma assoc_mult_vec_mat: assumes "v ∈ carrier_vec n1" and "A ∈ carrier_mat n1 n2" and "B ∈ carrier_mat n2 n3" shows "v ⇩v* (A * B) = (v ⇩v* A) ⇩v* B" using assms by (intro eq_vecI, auto simp add: mult_vec_mat_def mult_mat_vec_def assoc_scalar_prod) lemma mult_vec_mat_transpose: assumes "dim_vec v = dim_row A" shows "v ⇩v* A = (transpose_mat A) *⇩v (v::'a::comm_semiring_0 vec)" proof (simp add: mult_vec_mat_def mult_mat_vec_def, rule vec_cong, rule refl, simp) fix j show "v ∙ col A j = col A j ∙ v" by (rule scalar_prod_comm, simp add: assms) qed subsection ‹More about Matrices› definition nzrows :: "'a::zero mat ⇒ 'a vec list" where "nzrows A = filter (λr. r ≠ 0⇩v (dim_col A)) (rows A)" definition row_space :: "'a mat ⇒ 'a::semiring_0 vec set" where "row_space A = (λv. mult_vec_mat v A) ` (carrier_vec (dim_row A))" definition row_echelon :: "'a mat ⇒ 'a::field mat" where "row_echelon A = fst (gauss_jordan A (1⇩m (dim_row A)))" subsubsection ‹@{const nzrows}› lemma length_nzrows: "length (nzrows A) ≤ dim_row A" by (simp add: nzrows_def length_rows[symmetric] del: length_rows) lemma set_nzrows: "set (nzrows A) = set (rows A) - {0⇩v (dim_col A)}" by (auto simp add: nzrows_def) lemma nzrows_nth_not_zero: assumes "i < length (nzrows A)" shows "nzrows A ! i ≠ 0⇩v (dim_col A)" using assms unfolding nzrows_def using nth_mem by force subsubsection ‹@{const row_space}› lemma row_spaceI: assumes "x = v ⇩v* A" shows "x ∈ row_space A" unfolding row_space_def assms by (rule, fact mult_mat_vec_resize, fact resize_vec_carrier) lemma row_spaceE: assumes "x ∈ row_space A" obtains v where "v ∈ carrier_vec (dim_row A)" and "x = v ⇩v* A" using assms unfolding row_space_def by auto lemma row_space_alt: "row_space A = range (λv. mult_vec_mat v A)" proof show "row_space A ⊆ range (λv. v ⇩v* A)" unfolding row_space_def by auto next show "range (λv. v ⇩v* A) ⊆ row_space A" proof fix x assume "x ∈ range (λv. v ⇩v* A)" then obtain v where "x = v ⇩v* A" .. thus "x ∈ row_space A" by (rule row_spaceI) qed qed lemma row_space_mult: assumes "A ∈ carrier_mat nr nc" and "B ∈ carrier_mat nr nr" shows "row_space (B * A) ⊆ row_space A" proof from assms(2) assms(1) have "B * A ∈ carrier_mat nr nc" by (rule mult_carrier_mat) hence "nr = dim_row (B * A)" by blast fix x assume "x ∈ row_space (B * A)" then obtain v where "v ∈ carrier_vec nr" and x: "x = v ⇩v* (B * A)" unfolding ‹nr = dim_row (B * A)› by (rule row_spaceE) from this(1) assms(2) assms(1) have "x = (v ⇩v* B) ⇩v* A" unfolding x by (rule assoc_mult_vec_mat) thus "x ∈ row_space A" by (rule row_spaceI) qed lemma row_space_mult_unit: assumes "P ∈ Units (ring_mat TYPE('a::semiring_1) (dim_row A) b)" shows "row_space (P * A) = row_space A" proof - have A: "A ∈ carrier_mat (dim_row A) (dim_col A)" by simp from assms have P: "P ∈ carrier (ring_mat TYPE('a) (dim_row A) b)" and *: "∃Q∈(carrier (ring_mat TYPE('a) (dim_row A) b)). Q ⊗⇘ring_mat TYPE('a) (dim_row A) b⇙ P = 𝟭⇘ring_mat TYPE('a) (dim_row A) b⇙" unfolding Units_def by auto from P have P_in: "P ∈ carrier_mat (dim_row A) (dim_row A)" by (simp add: ring_mat_def) from * obtain Q where "Q ∈ carrier (ring_mat TYPE('a) (dim_row A) b)" and "Q ⊗⇘ring_mat TYPE('a) (dim_row A) b⇙ P = 𝟭⇘ring_mat TYPE('a) (dim_row A) b⇙" .. hence Q_in: "Q ∈ carrier_mat (dim_row A) (dim_row A)" and QP: "Q * P = 1⇩m (dim_row A)" by (simp_all add: ring_mat_def) show ?thesis proof from A P_in show "row_space (P * A) ⊆ row_space A" by (rule row_space_mult) next from A P_in Q_in have "Q * (P * A) = (Q * P) * A" by (simp only: assoc_mult_mat) also from A have "... = A" by (simp add: QP) finally have eq: "row_space A = row_space (Q * (P * A))" by simp show "row_space A ⊆ row_space (P * A)" unfolding eq by (rule row_space_mult, rule mult_carrier_mat, fact+) qed qed subsubsection ‹@{const row_echelon}› lemma row_eq_zero_iff_pivot_fun: assumes "pivot_fun A f (dim_col A)" and "i < dim_row (A::'a::zero_neq_one mat)" shows "(row A i = 0⇩v (dim_col A)) ⟷ (f i = dim_col A)" proof - have *: "dim_row A = dim_row A" .. show ?thesis proof assume a: "row A i = 0⇩v (dim_col A)" show "f i = dim_col A" proof (rule ccontr) assume "f i ≠ dim_col A" with pivot_funD(1)[OF * assms] have **: "f i < dim_col A" by simp with * assms have "A $$ (i, f i) = 1" by (rule pivot_funD) with ** assms(2) have "row A i $ (f i) = 1" by simp hence "(1::'a) = (0⇩v (dim_col A)) $ (f i)" by (simp only: a) also have "... = (0::'a)" using ** by simp finally show False by simp qed next assume a: "f i = dim_col A" show "row A i = 0⇩v (dim_col A)" proof (rule, simp_all add: assms(2)) fix j assume "j < dim_col A" hence "j < f i" by (simp only: a) with * assms show "A $$ (i, j) = 0" by (rule pivot_funD) qed qed qed lemma row_not_zero_iff_pivot_fun: assumes "pivot_fun A f (dim_col A)" and "i < dim_row (A::'a::zero_neq_one mat)" shows "(row A i ≠ 0⇩v (dim_col A)) ⟷ (f i < dim_col A)" proof (simp only: row_eq_zero_iff_pivot_fun[OF assms]) have "f i ≤ dim_col A" by (rule pivot_funD[where ?f = f], rule refl, fact+) thus "(f i ≠ dim_col A) = (f i < dim_col A)" by auto qed lemma pivot_fun_stabilizes: assumes "pivot_fun A f nc" and "i1 ≤ i2" and "i2 < dim_row A" and "nc ≤ f i1" shows "f i2 = nc" proof - from assms(2) have "i2 = i1 + (i2 - i1)" by simp then obtain k where "i2 = i1 + k" .. from assms(3) assms(4) show ?thesis unfolding ‹i2 = i1 + k› proof (induct k arbitrary: i1) case 0 from this(1) have "i1 < dim_row A" by simp from _ assms(1) this have "f i1 ≤ nc" by (rule pivot_funD, intro refl) with ‹nc ≤ f i1› show ?case by simp next case (Suc k) from Suc(2) have "Suc (i1 + k) < dim_row A" by simp hence "Suc i1 + k < dim_row A" by simp hence "Suc i1 < dim_row A" by simp hence "i1 < dim_row A" by simp have "nc ≤ f (Suc i1)" proof - have "f i1 < f (Suc i1) ∨ f (Suc i1) = nc" by (rule pivot_funD, rule refl, fact+) with Suc(3) show ?thesis by auto qed with ‹Suc i1 + k < dim_row A› have "f (Suc i1 + k) = nc" by (rule Suc(1)) thus ?case by simp qed qed lemma pivot_fun_mono_strict: assumes "pivot_fun A f nc" and "i1 < i2" and "i2 < dim_row A" and "f i1 < nc" shows "f i1 < f i2" proof - from assms(2) have "i2 - i1 ≠ 0" and "i2 = i1 + (i2 - i1)" by simp_all then obtain k where "k ≠ 0" and "i2 = i1 + k" .. from this(1) assms(3) assms(4) show ?thesis unfolding ‹i2 = i1 + k› proof (induct k arbitrary: i1) case 0 thus ?case by simp next case (Suc k) from Suc(3) have "Suc (i1 + k) < dim_row A" by simp hence "Suc i1 + k < dim_row A" by simp hence "Suc i1 < dim_row A" by simp hence "i1 < dim_row A" by simp have *: "f i1 < f (Suc i1)" proof - have "f i1 < f (Suc i1) ∨ f (Suc i1) = nc" by (rule pivot_funD, rule refl, fact+) with Suc(4) show ?thesis by auto qed show ?case proof (simp, cases "k = 0") case True show "f i1 < f (Suc (i1 + k))" by (simp add: True *) next case False have "f (Suc i1) ≤ f (Suc i1 + k)" proof (cases "f (Suc i1) < nc") case True from False ‹Suc i1 + k < dim_row A› True have "f (Suc i1) < f (Suc i1 + k)" by (rule Suc(1)) thus ?thesis by simp next case False hence "nc ≤ f (Suc i1)" by simp from assms(1) _ ‹Suc i1 + k < dim_row A› this have "f (Suc i1 + k) = nc" by (rule pivot_fun_stabilizes[where ?f=f], simp) moreover have "f (Suc i1) = nc" by (rule pivot_fun_stabilizes[where ?f=f], fact, rule le_refl, fact+) ultimately show ?thesis by simp qed also have "... = f (i1 + Suc k)" by simp finally have "f (Suc i1) ≤ f (i1 + Suc k)" . with * show "f i1 < f (Suc (i1 + k))" by simp qed qed qed lemma pivot_fun_mono: assumes "pivot_fun A f nc" and "i1 ≤ i2" and "i2 < dim_row A" shows "f i1 ≤ f i2" proof - from assms(2) have "i1 < i2 ∨ i1 = i2" by auto thus ?thesis proof assume "i1 < i2" show ?thesis proof (cases "f i1 < nc") case True from assms(1) ‹i1 < i2› assms(3) this have "f i1 < f i2" by (rule pivot_fun_mono_strict) thus ?thesis by simp next case False hence "nc ≤ f i1" by simp from assms(1) _ _ this have "f i1 = nc" proof (rule pivot_fun_stabilizes[where ?f=f], simp) from assms(2) assms(3) show "i1 < dim_row A" by (rule le_less_trans) qed moreover have "f i2 = nc" by (rule pivot_fun_stabilizes[where ?f=f], fact+) ultimately show ?thesis by simp qed next assume "i1 = i2" thus ?thesis by simp qed qed lemma row_echelon_carrier: assumes "A ∈ carrier_mat nr nc" shows "row_echelon A ∈ carrier_mat nr nc" proof - from assms have "dim_row A = nr" by simp let ?B = "1⇩m (dim_row A)" note assms moreover have "?B ∈ carrier_mat nr nr" by (simp add: ‹dim_row A = nr›) moreover from surj_pair obtain A' B' where *: "gauss_jordan A ?B = (A', B')" by metis ultimately have "A' ∈ carrier_mat nr nc" by (rule gauss_jordan_carrier) thus ?thesis by (simp add: row_echelon_def *) qed lemma dim_row_echelon[simp]: shows "dim_row (row_echelon A) = dim_row A" and "dim_col (row_echelon A) = dim_col A" proof - have "A ∈ carrier_mat (dim_row A) (dim_col A)" by simp hence "row_echelon A ∈ carrier_mat (dim_row A) (dim_col A)" by (rule row_echelon_carrier) thus "dim_row (row_echelon A) = dim_row A" and "dim_col (row_echelon A) = dim_col A" by simp_all qed lemma row_echelon_transform: obtains P where "P ∈ Units (ring_mat TYPE('a::field) (dim_row A) b)" and "row_echelon A = P * A" proof - let ?B = "1⇩m (dim_row A)" have "A ∈ carrier_mat (dim_row A) (dim_col A)" by simp moreover have "?B ∈ carrier_mat (dim_row A) (dim_row A)" by simp moreover from surj_pair obtain A' B' where *: "gauss_jordan A ?B = (A', B')" by metis ultimately have "∃P∈Units (ring_mat TYPE('a) (dim_row A) b). A' = P * A ∧ B' = P * ?B" by (rule gauss_jordan_transform) then obtain P where "P ∈ Units (ring_mat TYPE('a) (dim_row A) b)" and **: "A' = P * A ∧ B' = P * ?B" .. from this(1) show ?thesis proof from ** have "A' = P * A" .. thus "row_echelon A = P * A" by (simp add: row_echelon_def *) qed qed lemma row_space_row_echelon[simp]: "row_space (row_echelon A) = row_space A" proof - obtain P where *: "P ∈ Units (ring_mat TYPE('a::field) (dim_row A) Nil)" and **: "row_echelon A = P * A" by (rule row_echelon_transform) from * have "row_space (P * A) = row_space A" by (rule row_space_mult_unit) thus ?thesis by (simp only: **) qed lemma row_echelon_pivot_fun: obtains f where "pivot_fun (row_echelon A) f (dim_col (row_echelon A))" proof - let ?B = "1⇩m (dim_row A)" have "A ∈ carrier_mat (dim_row A) (dim_col A)" by simp moreover from surj_pair obtain A' B' where *: "gauss_jordan A ?B = (A', B')" by metis ultimately have "row_echelon_form A'" by (rule gauss_jordan_row_echelon) then obtain f where "pivot_fun A' f (dim_col A')" unfolding row_echelon_form_def .. hence "pivot_fun (row_echelon A) f (dim_col (row_echelon A))" by (simp add: row_echelon_def *) thus ?thesis .. qed lemma distinct_nzrows_row_echelon: "distinct (nzrows (row_echelon A))" unfolding nzrows_def proof (rule distinct_filterI, simp del: dim_row_echelon) let ?B = "row_echelon A" fix i j::nat assume "i < j" and "j < dim_row ?B" hence "i ≠ j" and "i < dim_row ?B" by simp_all assume ri: "row ?B i ≠ 0⇩v (dim_col ?B)" and rj: "row ?B j ≠ 0⇩v (dim_col ?B)" obtain f where pf: "pivot_fun ?B f (dim_col ?B)" by (fact row_echelon_pivot_fun) from rj have "f j < dim_col ?B" by (simp only: row_not_zero_iff_pivot_fun[OF pf ‹j < dim_row ?B›]) from _ pf ‹j < dim_row ?B› this ‹i < dim_row ?B› ‹i ≠ j› have *: "?B $$ (i, f j) = 0" by (rule pivot_funD(5), intro refl) show "row ?B i ≠ row ?B j" proof assume "row ?B i = row ?B j" hence "row ?B i $ (f j) = row ?B j $ (f j)" by simp with ‹i < dim_row ?B› ‹j < dim_row ?B› ‹f j < dim_col ?B› have "?B $$ (i, f j) = ?B $$ (j, f j)" by simp also from _ pf ‹j < dim_row ?B› ‹f j < dim_col ?B› have "... = 1" by (rule pivot_funD, intro refl) finally show False by (simp add: *) qed qed subsection ‹Converting Between Polynomials and Macaulay Matrices› definition poly_to_row :: "'a list ⇒ ('a ⇒⇩0 'b::zero) ⇒ 'b vec" where "poly_to_row ts p = vec_of_list (map (lookup p) ts)" definition polys_to_mat :: "'a list ⇒ ('a ⇒⇩0 'b::zero) list ⇒ 'b mat" where "polys_to_mat ts ps = mat_of_rows (length ts) (map (poly_to_row ts) ps)" definition list_to_fun :: "'a list ⇒ ('b::zero) list ⇒ 'a ⇒ 'b" where "list_to_fun ts cs t = (case map_of (zip ts cs) t of Some c ⇒ c | None ⇒ 0)" definition list_to_poly :: "'a list ⇒ 'b list ⇒ ('a ⇒⇩0 'b::zero)" where "list_to_poly ts cs = Abs_poly_mapping (list_to_fun ts cs)" definition row_to_poly :: "'a list ⇒ 'b vec ⇒ ('a ⇒⇩0 'b::zero)" where "row_to_poly ts r = list_to_poly ts (list_of_vec r)" definition mat_to_polys :: "'a list ⇒ 'b mat ⇒ ('a ⇒⇩0 'b::zero) list" where "mat_to_polys ts A = map (row_to_poly ts) (rows A)" lemma dim_poly_to_row: "dim_vec (poly_to_row ts p) = length ts" by (simp add: poly_to_row_def) lemma poly_to_row_index: assumes "i < length ts" shows "poly_to_row ts p $ i = lookup p (ts ! i)" by (simp add: poly_to_row_def vec_of_list_index assms) context term_powerprod begin lemma poly_to_row_scalar_mult: assumes "keys p ⊆ set ts" shows "row_to_poly ts (c ⋅⇩v (poly_to_row ts p)) = c ⋅ p" proof - have eq: "(vec (length ts) (λi. c * poly_to_row ts p $ i)) = (vec (length ts) (λi. c * lookup p (ts ! i)))" by (rule vec_cong, rule, simp only: poly_to_row_index) have *: "list_to_fun ts (list_of_vec (c ⋅⇩v (poly_to_row ts p))) = (λt. c * lookup p t)" proof (rule, simp add: list_to_fun_def smult_vec_def dim_poly_to_row eq, simp add: map_upt[of "λx. c * lookup p x"] map_of_zip_map, rule) fix t assume "t ∉ set ts" with assms(1) have "t ∉ keys p" by auto thus "c * lookup p t = 0" by (simp add: in_keys_iff) qed have **: "lookup (Abs_poly_mapping (list_to_fun ts (list_of_vec (c ⋅⇩v (poly_to_row ts p))))) = (λt. c * lookup p t)" proof (simp only: *, rule Abs_poly_mapping_inverse, simp, rule finite_subset, rule, simp) fix t assume "c * lookup p t ≠ 0" hence "lookup p t ≠ 0" using mult_not_zero by blast thus "t ∈ keys p" by (simp add: in_keys_iff) qed (fact finite_keys) show ?thesis unfolding row_to_poly_def by (rule poly_mapping_eqI) (simp only: list_to_poly_def ** lookup_map_scale) qed lemma poly_to_row_to_poly: assumes "keys p ⊆ set ts" shows "row_to_poly ts (poly_to_row ts p) = (p::'t ⇒⇩0 'b::semiring_1)" proof - have "1 ⋅⇩v (poly_to_row ts p) = poly_to_row ts p" by simp thus ?thesis using poly_to_row_scalar_mult[OF assms, of 1] by simp qed lemma lookup_list_to_poly: "lookup (list_to_poly ts cs) = list_to_fun ts cs" unfolding list_to_poly_def proof (rule Abs_poly_mapping_inverse, rule, rule finite_subset) show "{x. list_to_fun ts cs x ≠ 0} ⊆ set ts" proof (rule, simp) fix t assume "list_to_fun ts cs t ≠ 0" then obtain c where "map_of (zip ts cs) t = Some c" unfolding list_to_fun_def by fastforce thus "t ∈ set ts" by (meson in_set_zipE map_of_SomeD) qed qed simp lemma list_to_fun_Nil [simp]: "list_to_fun [] cs = 0" by (simp only: zero_fun_def, rule, simp add: list_to_fun_def) lemma list_to_poly_Nil [simp]: "list_to_poly [] cs = 0" by (rule poly_mapping_eqI, simp add: lookup_list_to_poly) lemma row_to_poly_Nil [simp]: "row_to_poly [] r = 0" by (simp only: row_to_poly_def, fact list_to_poly_Nil) lemma lookup_row_to_poly: assumes "distinct ts" and "dim_vec r = length ts" and "i < length ts" shows "lookup (row_to_poly ts r) (ts ! i) = r $ i" proof (simp only: row_to_poly_def lookup_list_to_poly) from assms(2) assms(3) have "i < dim_vec r" by simp have "map_of (zip ts (list_of_vec r)) (ts ! i) = Some ((list_of_vec r) ! i)" by (rule map_of_zip_nth, simp_all only: length_list_of_vec assms(2), fact, fact) also have "... = Some (r $ i)" by (simp only: list_of_vec_index) finally show "list_to_fun ts (list_of_vec r) (ts ! i) = r $ i" by (simp add: list_to_fun_def) qed lemma keys_row_to_poly: "keys (row_to_poly ts r) ⊆ set ts" proof fix t assume "t ∈ keys (row_to_poly ts r)" hence "lookup (row_to_poly ts r) t ≠ 0" by (simp add: in_keys_iff) thus "t ∈ set ts" proof (simp add: row_to_poly_def lookup_list_to_poly list_to_fun_def del: lookup_not_eq_zero_eq_in_keys split: option.splits) fix c assume "map_of (zip ts (list_of_vec r)) t = Some c" thus "t ∈ set ts" by (meson in_set_zipE map_of_SomeD) qed qed lemma lookup_row_to_poly_not_zeroE: assumes "lookup (row_to_poly ts r) t ≠ 0" obtains i where "i < length ts" and "t = ts ! i" proof - from assms have "t ∈ keys (row_to_poly ts r)" by (simp add: in_keys_iff) have "t ∈ set ts" by (rule, fact, fact keys_row_to_poly) then obtain i where "i < length ts" and "t = ts ! i" by (metis in_set_conv_nth) thus ?thesis .. qed lemma row_to_poly_zero [simp]: "row_to_poly ts (0⇩v (length ts)) = (0::'t ⇒⇩0 'b::zero)" proof - have eq: "map (λ_. 0::'b) [0..<length ts] = map (λ_. 0) ts" by (simp add: map_replicate_const) show ?thesis by (simp add: row_to_poly_def zero_vec_def, rule poly_mapping_eqI, simp add: lookup_list_to_poly list_to_fun_def eq map_of_zip_map) qed lemma row_to_poly_zeroD: assumes "distinct ts" and "dim_vec r = length ts" and "row_to_poly ts r = 0" shows "r = 0⇩v (length ts)" proof (rule, simp_all add: assms(2)) fix i assume "i < length ts" from assms(3) have "0 = lookup (row_to_poly ts r) (ts ! i)" by simp also from assms(1) assms(2) ‹i < length ts› have "... = r $ i" by (rule lookup_row_to_poly) finally show "r $ i = 0" by simp qed lemma row_to_poly_inj: assumes "distinct ts" and "dim_vec r1 = length ts" and "dim_vec r2 = length ts" and "row_to_poly ts r1 = row_to_poly ts r2" shows "r1 = r2" proof (rule, simp_all add: assms(2) assms(3)) fix i assume "i < length ts" have "r1 $ i = lookup (row_to_poly ts r1) (ts ! i)" by (simp only: lookup_row_to_poly[OF assms(1) assms(2) ‹i < length ts›]) also from assms(4) have "... = lookup (row_to_poly ts r2) (ts ! i)" by simp also from assms(1) assms(3) ‹i < length ts› have "... = r2 $ i" by (rule lookup_row_to_poly) finally show "r1 $ i = r2 $ i" . qed lemma row_to_poly_vec_plus: assumes "distinct ts" and "length ts = n" shows "row_to_poly ts (vec n (f1 + f2)) = row_to_poly ts (vec n f1) + row_to_poly ts (vec n f2)" proof (rule poly_mapping_eqI) fix t show "lookup (row_to_poly ts (vec n (f1 + f2))) t = lookup (row_to_poly ts (vec n f1) + row_to_poly ts (vec n f2)) t" (is "lookup ?l t = lookup (?r1 + ?r2) t") proof (cases "t ∈ set ts") case True then obtain j where j: "j < length ts" and t: "t = ts ! j" by (metis in_set_conv_nth) have d1: "dim_vec (vec n f1) = length ts" and d2: "dim_vec (vec n f2) = length ts" and da: "dim_vec (vec n (f1 + f2)) = length ts" by (simp_all add: assms(2)) from j have j': "j < n" by (simp only: assms(2)) show ?thesis by (simp only: t lookup_add lookup_row_to_poly[OF assms(1) d1 j] lookup_row_to_poly[OF assms(1) d2 j] lookup_row_to_poly[OF assms(1) da j] index_vec[OF j'], simp only: plus_fun_def) next case False with keys_row_to_poly[of ts "vec n (f1 + f2)"] keys_row_to_poly[of ts "vec n f1"] keys_row_to_poly[of ts "vec n f2"] have "t ∉ keys ?l" and "t ∉ keys ?r1" and "t ∉ keys ?r2" by auto from this(2) this(3) have "t ∉ keys (?r1 + ?r2)" by (meson Poly_Mapping.keys_add UnE in_mono) with ‹t ∉ keys ?l› show ?thesis by (simp add: in_keys_iff) qed qed lemma row_to_poly_vec_sum: assumes "distinct ts" and "length ts = n" shows "row_to_poly ts (vec n (λj. ∑i∈I. f i j)) = ((∑i∈I. row_to_poly ts (vec n (f i)))::'t ⇒⇩0 'b::comm_monoid_add)" proof (cases "finite I") case True thus ?thesis proof (induct I) case empty thus ?case by (simp add: zero_vec_def[symmetric] assms(2)[symmetric]) next case (insert x I) have "row_to_poly ts (vec n (λj. ∑i∈insert x I. f i j)) = row_to_poly ts (vec n (λj. f x j + (∑i∈I. f i j)))" by (simp add: insert(1) insert(2)) also have "... = row_to_poly ts (vec n (f x + (λj. (∑i∈I. f i j))))" by (simp only: plus_fun_def) also from assms have "... = row_to_poly ts (vec n (f x)) + row_to_poly ts (vec n (λj. (∑i∈I. f i j)))" by (rule row_to_poly_vec_plus) also have "... = row_to_poly ts (vec n (f x)) + (∑i∈I. row_to_poly ts (vec n (f i)))" by (simp only: insert(3)) also have "... = (∑i∈insert x I. row_to_poly ts (vec n (f i)))" by (simp add: insert(1) insert(2)) finally show ?case . qed next case False thus ?thesis by (simp add: zero_vec_def[symmetric] assms(2)[symmetric]) qed lemma row_to_poly_smult: assumes "distinct ts" and "dim_vec r = length ts" shows "row_to_poly ts (c ⋅⇩v r) = c ⋅ (row_to_poly ts r)" proof (rule poly_mapping_eqI, simp only: lookup_map_scale) fix t show "lookup (row_to_poly ts (c ⋅⇩v r)) t = c * lookup (row_to_poly ts r) t" (is "lookup ?l t = c * lookup ?r t") proof (cases "t ∈ set ts") case True then obtain j where j: "j < length ts" and t: "t = ts ! j" by (metis in_set_conv_nth) from assms(2) have dm: "dim_vec (c ⋅⇩v r) = length ts" by simp from j have j': "j < dim_vec r" by (simp only: assms(2)) show ?thesis by (simp add: t lookup_row_to_poly[OF assms j] lookup_row_to_poly[OF assms(1) dm j] index_smult_vec(1)[OF j']) next case False with keys_row_to_poly[of ts "c ⋅⇩v r"] keys_row_to_poly[of ts r] have "t ∉ keys ?l" and "t ∉ keys ?r" by auto thus ?thesis by (simp add: in_keys_iff) qed qed lemma poly_to_row_Nil [simp]: "poly_to_row [] p = vec 0 f" proof - have "dim_vec (poly_to_row [] p) = 0" by (simp add: dim_poly_to_row) thus ?thesis by auto qed lemma polys_to_mat_Nil [simp]: "polys_to_mat ts [] = mat 0 (length ts) f" by (simp add: polys_to_mat_def mat_eq_iff) lemma dim_row_polys_to_mat[simp]: "dim_row (polys_to_mat ts ps) = length ps" by (simp add: polys_to_mat_def) lemma dim_col_polys_to_mat[simp]: "dim_col (polys_to_mat ts ps) = length ts" by (simp add: polys_to_mat_def) lemma polys_to_mat_index: assumes "i < length ps" and "j < length ts" shows "(polys_to_mat ts ps) $$ (i, j) = lookup (ps ! i) (ts ! j)" by (simp add: polys_to_mat_def index_mat(1)[OF assms] mat_of_rows_def nth_map[OF assms(1)], rule poly_to_row_index, fact) lemma row_polys_to_mat: assumes "i < length ps" shows "row (polys_to_mat ts ps) i = poly_to_row ts (ps ! i)" proof - have "row (polys_to_mat ts ps) i = (map (poly_to_row ts) ps) ! i" unfolding polys_to_mat_def proof (rule mat_of_rows_row) from assms show "i < length (map (poly_to_row ts) ps)" by simp next show "map (poly_to_row ts) ps ! i ∈ carrier_vec (length ts)" unfolding nth_map[OF assms] by (rule carrier_vecI, fact dim_poly_to_row) qed also from assms have "... = poly_to_row ts (ps ! i)" by (rule nth_map) finally show ?thesis . qed lemma col_polys_to_mat: assumes "j < length ts" shows "col (polys_to_mat ts ps) j = vec_of_list (map (λp. lookup p (ts ! j)) ps)" by (simp add: vec_of_list_alt col_def, rule vec_cong, rule refl, simp add: polys_to_mat_index assms) lemma length_mat_to_polys[simp]: "length (mat_to_polys ts A) = dim_row A" by (simp add: mat_to_polys_def mat_to_list_def) lemma mat_to_polys_nth: assumes "i < dim_row A" shows "(mat_to_polys ts A) ! i = row_to_poly ts (row A i)" proof - from assms have "i < length (rows A)" by (simp only: length_rows) thus ?thesis by (simp add: mat_to_polys_def) qed lemma Keys_mat_to_polys: "Keys (set (mat_to_polys ts A)) ⊆ set ts" proof fix t assume "t ∈ Keys (set (mat_to_polys ts A))" then obtain p where "p ∈ set (mat_to_polys ts A)" and t: "t ∈ keys p" by (rule in_KeysE) from this(1) obtain i where "i < length (mat_to_polys ts A)" and p: "p = (mat_to_polys ts A) ! i" by (metis in_set_conv_nth) from this(1) have "i < dim_row A" by simp with p have "p = row_to_poly ts (row A i)" by (simp only: mat_to_polys_nth) with t have "t ∈ keys (row_to_poly ts (row A i))" by simp also have "... ⊆ set ts" by (fact keys_row_to_poly) finally show "t ∈ set ts" . qed lemma polys_to_mat_to_polys: assumes "Keys (set ps) ⊆ set ts" shows "mat_to_polys ts (polys_to_mat ts ps) = (ps::('t ⇒⇩0 'b::semiring_1) list)" unfolding mat_to_polys_def mat_to_list_def proof (rule nth_equalityI, simp_all) fix i assume "i < length ps" have *: "keys (ps ! i) ⊆ set ts" using ‹i < length ps› assms keys_subset_Keys nth_mem by blast show "row_to_poly ts (row (polys_to_mat ts ps) i) = ps ! i" by (simp only: row_polys_to_mat[OF ‹i < length ps›] poly_to_row_to_poly[OF *]) qed lemma mat_to_polys_to_mat: assumes "distinct ts" and "length ts = dim_col A" shows "(polys_to_mat ts (mat_to_polys ts A)) = A" proof fix i j assume i: "i < dim_row A" and j: "j < dim_col A" hence i': "i < length (mat_to_polys ts A)" and j': "j < length ts" by (simp, simp only: assms(2)) have r: "dim_vec (row A i) = length ts" by (simp add: assms(2)) show "polys_to_mat ts (mat_to_polys ts A) $$ (i, j) = A $$ (i, j)" by (simp only: polys_to_mat_index[OF i' j'] mat_to_polys_nth[OF ‹i < dim_row A›] lookup_row_to_poly[OF assms(1) r j'] index_row(1)[OF i j]) qed (simp_all add: assms) subsection ‹Properties of Macaulay Matrices› lemma row_to_poly_vec_times: assumes "distinct ts" and "length ts = dim_col A" shows "row_to_poly ts (v ⇩v* A) = ((∑i=0..<dim_row A. (v $ i) ⋅ (row_to_poly ts (row A i)))::'t ⇒⇩0 'b::comm_semiring_0)" proof (simp add: mult_vec_mat_def scalar_prod_def row_to_poly_vec_sum[OF assms], rule sum.cong, rule) fix i assume "i ∈ {0..<dim_row A}" hence "i < dim_row A" by simp have "dim_vec (row A i) = length ts" by (simp add: assms(2)) have *: "vec (dim_col A) (λj. col A j $ i) = vec (dim_col A) (λj. A $$ (i, j))" by (rule vec_cong, rule refl, simp add: ‹i < dim_row A›) have "vec (dim_col A) (λj. v $ i * col A j $ i) = v $ i ⋅⇩v vec (dim_col A) (λj. col A j $ i)" by (simp only: vec_scalar_mult_fun) also have "... = v $ i ⋅⇩v (row A i)" by (simp only: * row_def[symmetric]) finally show "row_to_poly ts (vec (dim_col A) (λj. v $ i * col A j $ i)) = (v $ i) ⋅ (row_to_poly ts (row A i))" by (simp add: row_to_poly_smult[OF assms(1) ‹dim_vec (row A i) = length ts›]) qed lemma vec_times_polys_to_mat: assumes "Keys (set ps) ⊆ set ts" and "v ∈ carrier_vec (length ps)" shows "row_to_poly ts (v ⇩v* (polys_to_mat ts ps)) = (∑(c, p)←zip (list_of_vec v) ps. c ⋅ p)" (is "?l = ?r") proof - from assms have *: "dim_vec v = length ps" by (simp only: carrier_dim_vec) have eq: "map (λi. v ∙ col (polys_to_mat ts ps) i) [0..<length ts] = map (λs. v ∙ (vec_of_list (map (λp. lookup p s) ps))) ts" proof (rule nth_equalityI, simp_all) fix i assume "i < length ts" hence "col (polys_to_mat ts ps) i = vec_of_list (map (λp. lookup p (ts ! i)) ps)" by (rule col_polys_to_mat) thus "v ∙ col (polys_to_mat ts ps) i = v ∙ map_vec (λp. lookup p (ts ! i)) (vec_of_list ps)" by simp qed show ?thesis proof (rule poly_mapping_eqI, simp add: mult_vec_mat_def row_to_poly_def lookup_list_to_poly eq list_to_fun_def map_of_zip_map lookup_sum_list o_def, intro conjI impI) fix t assume "t ∈ set ts" have "v ∙ vec_of_list (map (λp. lookup p t) ps) = (∑(c, p)←zip (list_of_vec v) ps. lookup (c ⋅ p) t)" proof (simp add: scalar_prod_def vec_of_list_index) have "(∑i = 0..<length ps. v $ i * lookup (ps ! i) t) = (∑i = 0..<length ps. (list_of_vec v) ! i * lookup (ps ! i) t)" by (rule sum.cong, rule refl, simp add: *) also have "... = (∑(c, p)←zip (list_of_vec v) ps. c * lookup p t)" by (simp only: sum_set_upt_eq_sum_list, rule sum_list_upt_zip, simp only: length_list_of_vec *) finally show "(∑i = 0..<length ps. v $ i * lookup (ps ! i) t) = (∑(c, p)←zip (list_of_vec v) ps. c * lookup p t)" . qed thus "v ∙ map_vec (λp. lookup p t) (vec_of_list ps) = (∑x←zip (list_of_vec v) ps. lookup (case x of (c, x) ⇒ c ⋅ x) t)" by (metis (mono_tags, lifting) case_prod_conv cond_case_prod_eta vec_of_list_map) next fix t assume "t ∉ set ts" with assms(1) have "t ∉ Keys (set ps)" by auto have "(∑(c, p)←zip (list_of_vec v) ps. lookup (c ⋅ p) t) = 0" proof (rule sum_list_zeroI, rule, simp) fix x assume "x ∈ (λ(c, p). c * lookup p t) ` set (zip (list_of_vec v) ps)" then obtain c p where cp: "(c, p) ∈ set (zip (list_of_vec v) ps)" and x: "x = c * lookup p t" by auto from cp have "p ∈ set ps" by (rule set_zip_rightD) with ‹t ∉ Keys (set ps)› have "t ∉ keys p" by (auto intro: in_KeysI) thus "x = 0" by (simp add: x in_keys_iff) qed thus "(∑x←zip (list_of_vec v) ps. lookup (case x of (c, x) ⇒ c ⋅ x) t) = 0" by (metis (mono_tags, lifting) case_prod_conv cond_case_prod_eta) qed qed lemma row_space_subset_phull: assumes "Keys (set ps) ⊆ set ts" shows "row_to_poly ts ` row_space (polys_to_mat ts ps) ⊆ phull (set ps)" (is "?r ⊆ ?h") proof fix q assume "q ∈ ?r" then obtain x where x1: "x ∈ row_space (polys_to_mat ts ps)" and q1: "q = row_to_poly ts x" .. from x1 obtain v where v: "v ∈ carrier_vec (dim_row (polys_to_mat ts ps))" and x: "x = v ⇩v* polys_to_mat ts ps" by (rule row_spaceE) from v have "v ∈ carrier_vec (length ps)" by (simp only: dim_row_polys_to_mat) thm vec_times_polys_to_mat with x q1 have q: "q = (∑(c, p)←zip (list_of_vec v) ps. c ⋅ p)" by (simp add: vec_times_polys_to_mat[OF assms]) show "q ∈ ?h" unfolding q by (rule phull.span_listI) qed lemma phull_subset_row_space: assumes "Keys (set ps) ⊆ set ts" shows "phull (set ps) ⊆ row_to_poly ts ` row_space (polys_to_mat ts ps)" (is "?h ⊆ ?r") proof fix q assume "q ∈ ?h" then obtain cs where l: "length cs = length ps" and q: "q = (∑(c, p)←zip cs ps. c ⋅ p)" by (rule phull.span_listE) let ?v = "vec_of_list cs" from l have *: "?v ∈ carrier_vec (length ps)" by (simp only: carrier_dim_vec dim_vec_of_list) let ?q = "?v ⇩v* polys_to_mat ts ps" show "q ∈ ?r" proof show "q = row_to_poly ts ?q" by (simp add: vec_times_polys_to_mat[OF assms *] q list_vec) next show "?q ∈ row_space (polys_to_mat ts ps)" by (rule row_spaceI, rule) qed qed lemma row_space_eq_phull: assumes "Keys (set ps) ⊆ set ts" shows "row_to_poly ts ` row_space (polys_to_mat ts ps) = phull (set ps)" by (rule, rule row_space_subset_phull, fact, rule phull_subset_row_space, fact) lemma row_space_row_echelon_eq_phull: assumes "Keys (set ps) ⊆ set ts" shows "row_to_poly ts ` row_space (row_echelon (polys_to_mat ts ps)) = phull (set ps)" by (simp add: row_space_eq_phull[OF assms]) lemma phull_row_echelon: assumes "Keys (set ps) ⊆ set ts" and "distinct ts" shows "phull (set (mat_to_polys ts (row_echelon (polys_to_mat ts ps)))) = phull (set ps)" proof - have len_ts: "length ts = dim_col (row_echelon (polys_to_mat ts ps))" by simp have *: "Keys (set (mat_to_polys ts (row_echelon (polys_to_mat ts ps)))) ⊆ set ts" by (fact Keys_mat_to_polys) show ?thesis by (simp only: row_space_eq_phull[OF *, symmetric] mat_to_polys_to_mat[OF assms(2) len_ts], rule row_space_row_echelon_eq_phull, fact) qed lemma pmdl_row_echelon: assumes "Keys (set ps) ⊆ set ts" and "distinct ts" shows "pmdl (set (mat_to_polys ts (row_echelon (polys_to_mat ts ps)))) = pmdl (set ps)" (is "?l = ?r") proof show "?l ⊆ ?r" by (rule pmdl.span_subset_spanI, rule subset_trans, rule phull.span_superset, simp only: phull_row_echelon[OF assms] phull_subset_module) next show "?r ⊆ ?l" by (rule pmdl.span_subset_spanI, rule subset_trans, rule phull.span_superset, simp only: phull_row_echelon[OF assms, symmetric] phull_subset_module) qed end (* term_powerprod *) context ordered_term begin lemma lt_row_to_poly_pivot_fun: assumes "card S = dim_col (A::'b::semiring_1 mat)" and "pivot_fun A f (dim_col A)" and "i < dim_row A" and "f i < dim_col A" shows "lt ((mat_to_polys (pps_to_list S) A) ! i) = (pps_to_list S) ! (f i)" proof - let ?ts = "pps_to_list S" have len_ts: "length ?ts = dim_col A" by (simp add: length_pps_to_list assms(1)) show ?thesis proof (simp add: mat_to_polys_nth[OF assms(3)], rule lt_eqI) have "lookup (row_to_poly ?ts (row A i)) (?ts ! f i) = (row A i) $ (f i)" by (rule lookup_row_to_poly, fact distinct_pps_to_list, simp_all add: len_ts assms(4)) also have "... = A $$ (i, f i)" using assms(3) assms(4) by simp also have "... = 1" by (rule pivot_funD, rule refl, fact+) finally show "lookup (row_to_poly ?ts (row A i)) (?ts ! f i) ≠ 0" by simp next fix u assume a: "lookup (row_to_poly ?ts (row A i)) u ≠ 0" then obtain j where j: "j < length ?ts" and u: "u = ?ts ! j" by (rule lookup_row_to_poly_not_zeroE) from j have "j < card S" and "j < dim_col A" by (simp only: length_pps_to_list, simp only: len_ts) from a have "0 ≠ lookup (row_to_poly ?ts (row A i)) (?ts ! j)" by (simp add: u) also have "lookup (row_to_poly ?ts (row A i)) (?ts ! j) = (row A i) $ j" by (rule lookup_row_to_poly, fact distinct_pps_to_list, simp add: len_ts, fact) finally have "A $$ (i, j) ≠ 0" using assms(3) ‹j < dim_col A› by simp from _ ‹j < card S› show "u ≼⇩t ?ts ! f i" unfolding u proof (rule pps_to_list_nth_leI) show "f i ≤ j" proof (rule ccontr) assume "¬ f i ≤ j" hence "j < f i" by simp have "A $$ (i, j) = 0" by (rule pivot_funD, rule refl, fact+) with ‹A $$ (i, j) ≠ 0› show False .. qed qed qed qed lemma lc_row_to_poly_pivot_fun: assumes "card S = dim_col (A::'b::semiring_1 mat)" and "pivot_fun A f (dim_col A)" and "i < dim_row A" and "f i < dim_col A" shows "lc ((mat_to_polys (pps_to_list S) A) ! i) = 1" proof - let ?ts = "pps_to_list S" have len_ts: "length ?ts = dim_col A" by (simp only: length_pps_to_list assms(1)) have "lookup (row_to_poly ?ts (row A i)) (?ts ! f i) = (row A i) $ (f i)" by (rule lookup_row_to_poly, fact distinct_pps_to_list, simp_all add: len_ts assms(4)) also have "... = A $$ (i, f i)" using assms(3) assms(4) by simp finally have eq: "lookup (row_to_poly ?ts (row A i)) (?ts ! f i) = A $$ (i, f i)" . show ?thesis by (simp only: lc_def lt_row_to_poly_pivot_fun[OF assms], simp only: mat_to_polys_nth[OF assms(3)] eq, rule pivot_funD, rule refl, fact+) qed lemma lt_row_to_poly_pivot_fun_less: assumes "card S = dim_col (A::'b::semiring_1 mat)" and "pivot_fun A f (dim_col A)" and "i1 < i2" and "i2 < dim_row A" and "f i1 < dim_col A" and "f i2 < dim_col A" shows "(pps_to_list S) ! (f i2) ≺⇩t (pps_to_list S) ! (f i1)" proof - let ?ts = "pps_to_list S" have len_ts: "length ?ts = dim_col A" by (simp add: length_pps_to_list assms(1)) from assms(3) assms(4) have "i1 < dim_row A" by simp show ?thesis by (rule pps_to_list_nth_lessI, rule pivot_fun_mono_strict[where ?f=f], fact, fact, fact, fact, simp only: assms(1) assms(6)) qed lemma lt_row_to_poly_pivot_fun_eqD: assumes "card S = dim_col (A::'b::semiring_1 mat)" and "pivot_fun A f (dim_col A)" and "i1 < dim_row A" and "i2 < dim_row A" and "f i1 < dim_col A" and "f i2 < dim_col A" and "(pps_to_list S) ! (f i1) = (pps_to_list S) ! (f i2)" shows "i1 = i2" proof (rule linorder_cases) assume "i1 < i2" from assms(1) assms(2) this assms(4) assms(5) assms(6) have "(pps_to_list S) ! (f i2) ≺⇩t (pps_to_list S) ! (f i1)" by (rule lt_row_to_poly_pivot_fun_less) with assms(7) show ?thesis by auto next assume "i2 < i1" from assms(1) assms(2) this assms(3) assms(6) assms(5) have "(pps_to_list S) ! (f i1) ≺⇩t (pps_to_list S) ! (f i2)" by (rule lt_row_to_poly_pivot_fun_less) with assms(7) show ?thesis by auto qed lemma lt_row_to_poly_pivot_in_keysD: assumes "card S = dim_col (A::'b::semiring_1 mat)" and "pivot_fun A f (dim_col A)" and "i1 < dim_row A" and "i2 < dim_row A" and "f i1 < dim_col A" and "(pps_to_list S) ! (f i1) ∈ keys ((mat_to_polys (pps_to_list S) A) ! i2)" shows "i1 = i2" proof (rule ccontr) assume "i1 ≠ i2" hence "i2 ≠ i1" by simp let ?ts = "pps_to_list S" have len_ts: "length ?ts = dim_col A" by (simp only: length_pps_to_list assms(1)) from assms(6) have "0 ≠ lookup (row_to_poly ?ts (row A i2)) (?ts ! (f i1))" by (auto simp: mat_to_polys_nth[OF assms(4)]) also have "lookup (row_to_poly ?ts (row A i2)) (?ts ! (f i1)) = (row A i2) $ (f i1)" by (rule lookup_row_to_poly, fact distinct_pps_to_list, simp_all add: len_ts assms(5)) finally have "A $$ (i2, f i1) ≠ 0" using assms(4) assms(5) by simp moreover have "A $$ (i2, f i1) = 0" by (rule pivot_funD(5), rule refl, fact+) ultimately show False .. qed lemma lt_row_space_pivot_fun: assumes "card S = dim_col (A::'b::{comm_semiring_0,semiring_1_no_zero_divisors} mat)" and "pivot_fun A f (dim_col A)" and "p ∈ row_to_poly (pps_to_list S) ` row_space A" and "p ≠ 0" shows "lt p ∈ lt_set (set (mat_to_polys (pps_to_list S) A))" proof - let ?ts = "pps_to_list S" let ?I = "{0..<dim_row A}" have len_ts: "length ?ts = dim_col A" by (simp add: length_pps_to_list assms(1)) from assms(3) obtain x where "x ∈ row_space A" and p: "p = row_to_poly ?ts x" .. from this(1) obtain v where "v ∈ carrier_vec (dim_row A)" and x: "x = v ⇩v* A" by (rule row_spaceE) have p': "p = (∑i∈?I. (v $ i) ⋅ (row_to_poly ?ts (row A i)))" unfolding p x by (rule row_to_poly_vec_times, fact distinct_pps_to_list, fact len_ts) have "lt (∑i = 0..<dim_row A. (v $ i) ⋅ (row_to_poly ?ts (row A i))) ∈ lt_set ((λi. (v $ i) ⋅ (row_to_poly ?ts (row A i))) ` {0..<dim_row A})" proof (rule lt_sum_distinct_in_lt_set, rule, simp add: p'[symmetric] ‹p ≠ 0›) fix i1 i2 let ?p1 = "(v $ i1) ⋅ (row_to_poly ?ts (row A i1))" let ?p2 = "(v $ i2) ⋅ (row_to_poly ?ts (row A i2))" assume "i1 ∈ ?I" and "i2 ∈ ?I" hence "i1 < dim_row A" and "i2 < dim_row A" by simp_all assume "?p1 ≠ 0" hence "v $ i1 ≠ 0" and "row_to_poly ?ts (row A i1) ≠ 0" by auto hence "row A i1 ≠ 0⇩v (length ?ts)" by auto hence "f i1 < dim_col A" by (simp add: len_ts row_not_zero_iff_pivot_fun[OF assms(2) ‹i1 < dim_row A›]) have "lt ?p1 = lt (row_to_poly ?ts (row A i1))" by (rule lt_map_scale, fact) also have "... = lt ((mat_to_polys ?ts A) ! i1)" by (simp only: mat_to_polys_nth[OF ‹i1 < dim_row A›]) also have "... = ?ts ! (f i1)" by (rule lt_row_to_poly_pivot_fun, fact+) finally have lt1: "lt ?p1 = ?ts ! (f i1)" . assume "?p2 ≠ 0" hence "v $ i2 ≠ 0" and "row_to_poly ?ts (row A i2) ≠ 0" by auto hence "row A i2 ≠ 0⇩v (length ?ts)" by auto hence "f i2 < dim_col A" by (simp add: len_ts row_not_zero_iff_pivot_fun[OF assms(2) ‹i2 < dim_row A›]) have "lt ?p2 = lt (row_to_poly ?ts (row A i2))" by (rule lt_map_scale, fact) also have "... = lt ((mat_to_polys ?ts A) ! i2)" by (simp only: mat_to_polys_nth[OF ‹i2 < dim_row A›]) also have "... = ?ts ! (f i2)" by (rule lt_row_to_poly_pivot_fun, fact+) finally have lt2: "lt ?p2 = ?ts ! (f i2)" . assume "lt ?p1 = lt ?p2" with assms(1) assms(2) ‹i1 < dim_row A› ‹i2 < dim_row A› ‹f i1 < dim_col A› ‹f i2 < dim_col A› show "i1 = i2" unfolding lt1 lt2 by (rule lt_row_to_poly_pivot_fun_eqD) qed also have "... ⊆ lt_set ((λi. row_to_poly ?ts (row A i)) ` {0..<dim_row A})" proof fix s assume "s ∈ lt_set ((λi. (v $ i) ⋅ (row_to_poly ?ts (row A i))) ` {0..<dim_row A})" then obtain f where "f ∈ (λi. (v $ i) ⋅ (row_to_poly ?ts (row A i))) ` {0..<dim_row A}" and "f ≠ 0" and "lt f = s" by (rule lt_setE) from this(1) obtain i where "i ∈ {0..<dim_row A}" and f: "f = (v $ i) ⋅ (row_to_poly ?ts (row A i))" .. from this(2) ‹f ≠ 0› have "v $ i ≠ 0" and **: "row_to_poly ?ts (row A i) ≠ 0" by auto from ‹lt f = s› have "s = lt ((v $ i) ⋅ (row_to_poly ?ts (row A i)))" by (simp only: f) also from ‹v $ i ≠ 0› have "... = lt (row_to_poly ?ts (row A i))" by (rule lt_map_scale) finally have s: "s = lt (row_to_poly ?ts (row A i))" . show "s ∈ lt_set ((λi. row_to_poly ?ts (row A i)) ` {0..<dim_row A})" unfolding s by (rule lt_setI, rule, rule refl, fact+) qed also have "... = lt_set ((λr. row_to_poly ?ts r) ` (row A ` {0..<dim_row A}))" by (simp only: image_comp o_def) also have "... = lt_set (set (map (λr. row_to_poly ?ts r) (map (row A) [0..<dim_row A])))" by (metis image_set set_upt) also have "... = lt_set (set (mat_to_polys ?ts A))" by (simp only: mat_to_polys_def rows_def) finally show ?thesis unfolding p' . qed subsection ‹Functions ‹Macaulay_mat› and ‹Macaulay_list›› definition Macaulay_mat :: "('t ⇒⇩0 'b) list ⇒ 'b::field mat" where "Macaulay_mat ps = polys_to_mat (Keys_to_list ps) ps" definition Macaulay_list :: "('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b::field) list" where "Macaulay_list ps = filter (λp. p ≠ 0) (mat_to_polys (Keys_to_list ps) (row_echelon (Macaulay_mat ps)))" lemma dim_Macaulay_mat[simp]: "dim_row (Macaulay_mat ps) = length ps" "dim_col (Macaulay_mat ps) = card (Keys (set ps))" by (simp_all add: Macaulay_mat_def length_Keys_to_list) lemma Macaulay_list_Nil [simp]: "Macaulay_list [] = ([]::('t ⇒⇩0 'b::field) list)" (is "?l = _") proof - have "length ?l ≤ length (mat_to_polys (Keys_to_list ([]::('t ⇒⇩0 'b) list)) (row_echelon (Macaulay_mat ([]::('t ⇒⇩0 'b) list))))" unfolding Macaulay_list_def by (fact length_filter_le) also have "... = 0" by simp finally show ?thesis by simp qed lemma set_Macaulay_list: "set (Macaulay_list ps) = set (mat_to_polys (Keys_to_list ps) (row_echelon (Macaulay_mat ps))) - {0}" by (auto simp add: Macaulay_list_def) lemma Keys_Macaulay_list: "Keys (set (Macaulay_list ps)) ⊆ Keys (set ps)" proof - have "Keys (set (Macaulay_list ps)) ⊆ set (Keys_to_list ps)" by (simp only: set_Macaulay_list Keys_minus_zero, fact Keys_mat_to_polys) also have "... = Keys (set ps)" by (fact set_Keys_to_list) finally show ?thesis . qed lemma in_Macaulay_listE: assumes "p ∈ set (Macaulay_list ps)" and "pivot_fun (row_echelon (Macaulay_mat ps)) f (dim_col (row_echelon (Macaulay_mat ps)))" obtains i where "i < dim_row (row_echelon (Macaulay_mat ps))" and "p = (mat_to_polys (Keys_to_list ps) (row_echelon (Macaulay_mat ps))) ! i" and "f i < dim_col (row_echelon (Macaulay_mat ps))" proof - let ?ts = "Keys_to_list ps" let ?A = "Macaulay_mat ps" let ?E = "row_echelon ?A" from assms(1) have "p ∈ set (mat_to_polys ?ts ?E) - {0}" by (simp add: set_Macaulay_list) hence "p ∈ set (mat_to_polys ?ts ?E)" and "p ≠ 0" by auto from this(1) obtain i where "i < length (mat_to_polys ?ts ?E)" and p: "p = (mat_to_polys ?ts ?E) ! i" by (metis in_set_conv_nth) from this(1) have "i < dim_row ?E" and "i < dim_row ?A" by simp_all from this(1) p show ?thesis proof from ‹p ≠ 0› have "0 ≠ (mat_to_polys ?ts ?E) ! i" by (simp only: p) also have "(mat_to_polys ?ts ?E) ! i = row_to_poly ?ts (row ?E i)" by (simp only: Macaulay_list_def mat_to_polys_nth[OF ‹i < dim_row ?E›]) finally have *: "row_to_poly ?ts (row ?E i) ≠ 0" by simp have "row ?E i ≠ 0⇩v (length ?ts)" proof assume "row ?E i = 0⇩v (length ?ts)" with * show False by simp qed hence "row ?E i ≠ 0⇩v (dim_col ?E)" by (simp add: length_Keys_to_list) thus "f i < dim_col ?E" by (simp only: row_not_zero_iff_pivot_fun[OF assms(2) ‹i < dim_row ?E›]) qed qed lemma phull_Macaulay_list: "phull (set (Macaulay_list ps)) = phull (set ps)" proof - have *: "Keys (set ps) ⊆ set (Keys_to_list ps)" by (simp add: set_Keys_to_list) have "phull (set (Macaulay_list ps)) = phull (set (mat_to_polys (Keys_to_list ps) (row_echelon (Macaulay_mat ps))))" by (simp only: set_Macaulay_list phull.span_Diff_zero) also have "... = phull (set ps)" by (simp only: Macaulay_mat_def phull_row_echelon[OF * distinct_Keys_to_list]) finally show ?thesis . qed lemma pmdl_Macaulay_list: "pmdl (set (Macaulay_list ps)) = pmdl (set ps)" proof - have *: "Keys (set ps) ⊆ set (Keys_to_list ps)" by (simp add: set_Keys_to_list) have "pmdl (set (Macaulay_list ps)) = pmdl (set (mat_to_polys (Keys_to_list ps) (row_echelon (Macaulay_mat ps))))" by (simp only: set_Macaulay_list pmdl.span_Diff_zero) also have "... = pmdl (set ps)" by (simp only: Macaulay_mat_def pmdl_row_echelon[OF * distinct_Keys_to_list]) finally show ?thesis . qed lemma Macaulay_list_is_monic_set: "is_monic_set (set (Macaulay_list ps))" proof (rule is_monic_setI) let ?ts = "Keys_to_list ps" let ?E = "row_echelon (Macaulay_mat ps)" fix p assume "p ∈ set (Macaulay_list ps)" obtain h where "pivot_fun ?E h (dim_col ?E)" by (rule row_echelon_pivot_fun) with ‹p ∈ set (Macaulay_list ps)› obtain i where "i < dim_row ?E" and p: "p = (mat_to_polys ?ts ?E) ! i" and "h i < dim_col ?E" by (rule in_Macaulay_listE) show "lc p = 1" unfolding p Keys_to_list_eq_pps_to_list by (rule lc_row_to_poly_pivot_fun, simp, fact+) qed lemma Macaulay_list_not_zero: "0 ∉ set (Macaulay_list ps)" by (simp add: Macaulay_list_def) lemma Macaulay_list_distinct_lt: assumes "x ∈ set (Macaulay_list ps)" and "y ∈ set (Macaulay_list ps)" and "x ≠ y" shows "lt x ≠ lt y" proof let ?S = "Keys (set ps)" let ?ts = "Keys_to_list ps" let ?E = "row_echelon (Macaulay_mat ps)" assume "lt x = lt y" obtain h where pf: "pivot_fun ?E h (dim_col ?E)" by (rule row_echelon_pivot_fun) with assms(1) obtain i1 where "i1 < dim_row ?E" and x: "x = (mat_to_polys ?ts ?E) ! i1" and "h i1 < dim_col ?E" by (rule in_Macaulay_listE) from assms(2) pf obtain i2 where "i2 < dim_row ?E" and y: "y = (mat_to_polys ?ts ?E) ! i2" and "h i2 < dim_col ?E" by (rule in_Macaulay_listE) have "lt x = ?ts ! (h i1)" by (simp only: x Keys_to_list_eq_pps_to_list, rule lt_row_to_poly_pivot_fun, simp, fact+) moreover have "lt y = ?ts ! (h i2)" by (simp only: y Keys_to_list_eq_pps_to_list, rule lt_row_to_poly_pivot_fun, simp, fact+) ultimately have "?ts ! (h i1) = ?ts ! (h i2)" by (simp only: ‹lt x = lt y›) hence "pps_to_list (Keys (set ps)) ! h i1 = pps_to_list (Keys (set ps)) ! h i2" by (simp only: Keys_to_list_eq_pps_to_list) have "i1 = i2" proof (rule lt_row_to_poly_pivot_fun_eqD) show "card ?S = dim_col ?E" by simp qed fact+ hence "x = y" by (simp only: x y) with ‹x ≠ y› show False .. qed lemma Macaulay_list_lt: assumes "p ∈ phull (set ps)" and "p ≠ 0" obtains g where "g ∈ set (Macaulay_list ps)" and "g ≠ 0" and "lt p = lt g" proof - let ?S = "Keys (set ps)" let ?ts = "Keys_to_list ps" let ?E = "row_echelon (Macaulay_mat ps)" let ?gs = "mat_to_polys ?ts ?E" have "finite ?S" by (rule finite_Keys, rule) have "?S ⊆ set ?ts" by (simp only: set_Keys_to_list) from assms(1) ‹?S ⊆ set ?ts› have "p ∈ row_to_poly ?ts ` row_space ?E" by (simp only: Macaulay_mat_def row_space_row_echelon_eq_phull[symmetric]) hence "p ∈ row_to_poly (pps_to_list ?S) ` row_space ?E" by (simp only: Keys_to_list_eq_pps_to_list) obtain f where "pivot_fun ?E f (dim_col ?E)" by (rule row_echelon_pivot_fun) have "lt p ∈ lt_set (set ?gs)" unfolding Keys_to_list_eq_pps_to_list by (rule lt_row_space_pivot_fun, simp, fact+) then obtain g where "g ∈ set ?gs" and "g ≠ 0" and "lt g = lt p" by (rule lt_setE) show ?thesis proof from ‹g ∈ set ?gs› ‹g ≠ 0› show "g ∈ set (Macaulay_list ps)" by (simp add: set_Macaulay_list) next from ‹lt g = lt p› show "lt p = lt g" by simp qed fact qed end (* ordered_term *) end (* theory *)
Theory F4
(* Author: Alexander Maletzky *) section ‹Faug\`ere's F4 Algorithm› theory F4 imports Macaulay_Matrix Algorithm_Schema begin text ‹This theory implements Faug\`ere's F4 algorithm based on @{const gd_term.gb_schema_direct}.› subsection ‹Symbolic Preprocessing› context gd_term begin definition sym_preproc_aux_term1 :: "('a ⇒ nat) ⇒ ((('t ⇒⇩0 'b) list × 't list × 't list × ('t ⇒⇩0 'b) list) × (('t ⇒⇩0 'b) list × 't list × 't list × ('t ⇒⇩0 'b) list)) set" where "sym_preproc_aux_term1 d = {((gs1, ks1, ts1, fs1), (gs2::('t ⇒⇩0 'b) list, ks2, ts2, fs2)). ∃t2∈set ts2. ∀t1∈set ts1. t1 ≺⇩t t2}" definition sym_preproc_aux_term2 :: "('a ⇒ nat) ⇒ ((('t ⇒⇩0 'b::zero) list × 't list × 't list × ('t ⇒⇩0 'b) list) × (('t ⇒⇩0 'b) list × 't list × 't list × ('t ⇒⇩0 'b) list)) set" where "sym_preproc_aux_term2 d = {((gs1, ks1, ts1, fs1), (gs2::('t ⇒⇩0 'b) list, ks2, ts2, fs2)). gs1 = gs2 ∧ dgrad_set_le d (pp_of_term ` set ts1) (pp_of_term ` (Keys (set gs2) ∪ set ts2))}" definition sym_preproc_aux_term where "sym_preproc_aux_term d = sym_preproc_aux_term1 d ∩ sym_preproc_aux_term2 d" lemma wfp_on_ord_term_strict: assumes "dickson_grading d" shows "wfp_on (≺⇩t) (pp_of_term -` dgrad_set d m)" proof (rule wfp_onI_min) fix x Q assume "x ∈ Q" and "Q ⊆ pp_of_term -` dgrad_set d m" from wf_dickson_less_v[OF assms, of m] ‹x ∈ Q› obtain z where "z ∈ Q" and *: "⋀y. dickson_less_v d m y z ⟹ y ∉ Q" by (rule wfE_min[to_pred], blast) from this(1) ‹Q ⊆ pp_of_term -` dgrad_set d m› have "z ∈ pp_of_term -` dgrad_set d m" .. show "∃z∈Q. ∀y ∈ pp_of_term -` dgrad_set d m. y ≺⇩t z ⟶ y ∉ Q" proof (intro bexI ballI impI, rule *) fix y assume "y ∈ pp_of_term -` dgrad_set d m" and "y ≺⇩t z" from this(1) ‹z ∈ pp_of_term -` dgrad_set d m› have "d (pp_of_term y) ≤ m" and "d (pp_of_term z) ≤ m" by (simp_all add: dgrad_set_def) thus "dickson_less_v d m y z" using ‹y ≺⇩t z› by (rule dickson_less_vI) qed fact qed lemma sym_preproc_aux_term1_wf_on: assumes "dickson_grading d" shows "wfp_on (λx y. (x, y) ∈ sym_preproc_aux_term1 d) {x. set (fst (snd (snd x))) ⊆ pp_of_term -` dgrad_set d m}" proof (rule wfp_onI_min) let ?B = "pp_of_term -` dgrad_set d m" let ?A = "{x::(('t ⇒⇩0 'b) list × 't list × 't list × ('t ⇒⇩0 'b) list). set (fst (snd (snd x))) ⊆ ?B}" have A_sub_Pow: "set ` fst ` snd ` snd ` ?A ⊆ Pow ?B" by auto fix x Q assume "x ∈ Q" and "Q ⊆ ?A" let ?Q = "{ord_term_lin.Max (set (fst (snd (snd q)))) | q. q ∈ Q ∧ fst (snd (snd q)) ≠ []}" show "∃z∈Q. ∀y∈{x. set (fst (snd (snd x))) ⊆ ?B}. (y, z) ∈ sym_preproc_aux_term1 d ⟶ y ∉ Q" proof (cases "∃z∈Q. fst (snd (snd z)) = []") case True then obtain z where "z ∈ Q" and "fst (snd (snd z)) = []" .. show ?thesis proof (intro bexI ballI impI) fix y assume "(y, z) ∈ sym_preproc_aux_term1 d" then obtain t where "t ∈ set (fst (snd (snd z)))" unfolding sym_preproc_aux_term1_def by auto with ‹fst (snd (snd z)) = []› show "y ∉ Q" by simp qed fact next case False hence *: "q ∈ Q ⟹ fst (snd (snd q)) ≠ []" for q by blast with ‹x ∈ Q› have "fst (snd (snd x)) ≠ []" by simp from assms have "wfp_on (≺⇩t) ?B" by (rule wfp_on_ord_term_strict) moreover from ‹x ∈ Q› ‹fst (snd (snd x)) ≠ []› have "ord_term_lin.Max (set (fst (snd (snd x)))) ∈ ?Q" by blast moreover have "?Q ⊆ ?B" proof (rule, simp, elim exE conjE, simp) fix a b c d0 assume "(a, b, c, d0) ∈ Q" and "c ≠ []" from this(1) ‹Q ⊆ ?A› have "(a, b, c, d0) ∈ ?A" .. hence "pp_of_term ` set c ⊆ dgrad_set d m" by auto moreover have "pp_of_term (ord_term_lin.Max (set c)) ∈ pp_of_term ` set c" proof from ‹c ≠ []› show "ord_term_lin.Max (set c) ∈ set c" by simp qed (fact refl) ultimately show "pp_of_term (ord_term_lin.Max (set c)) ∈ dgrad_set d m" .. qed ultimately obtain t where "t ∈ ?Q" and min: "⋀s. s ≺⇩t t ⟹ s ∉ ?Q" by (rule wfp_onE_min) blast from this(1) obtain z where "z ∈ Q" and "fst (snd (snd z)) ≠ []" and t: "t = ord_term_lin.Max (set (fst (snd (snd z))))" by blast show ?thesis proof (intro bexI ballI impI, rule) fix y assume "y ∈ ?A" and "(y, z) ∈ sym_preproc_aux_term1 d" and "y ∈ Q" from this(2) obtain t' where "t' ∈ set (fst (snd (snd z)))" and **: "⋀s. s ∈ set (fst (snd (snd y))) ⟹ s ≺⇩t t'" unfolding sym_preproc_aux_term1_def by auto from ‹y ∈ Q› have "fst (snd (snd y)) ≠ []" by (rule *) with ‹y ∈ Q› have "ord_term_lin.Max (set (fst (snd (snd y)))) ∈ ?Q" (is "?s ∈ _") by blast from ‹fst (snd (snd y)) ≠ []› have "?s ∈ set (fst (snd (snd y)))" by simp hence "?s ≺⇩t t'" by (rule **) also from ‹t' ∈ set (fst (snd (snd z)))› have "t' ≼⇩t t" unfolding t using ‹fst (snd (snd z)) ≠ []› by simp finally have "?s ∉ ?Q" by (rule min) from this ‹?s ∈ ?Q› show False .. qed fact qed qed lemma sym_preproc_aux_term_wf: assumes "dickson_grading d" shows "wf (sym_preproc_aux_term d)" proof (rule wfI_min) fix x::"(('t ⇒⇩0 'b) list × 't list × 't list × ('t ⇒⇩0 'b) list)" and Q assume "x ∈ Q" let ?A = "Keys (set (fst x)) ∪ set (fst (snd (snd x)))" have "finite ?A" by (simp add: finite_Keys) hence "finite (pp_of_term ` ?A)" by (rule finite_imageI) then obtain m where "pp_of_term ` ?A ⊆ dgrad_set d m" by (rule dgrad_set_exhaust) hence A: "?A ⊆ pp_of_term -` dgrad_set d m" by blast let ?B = "pp_of_term -` dgrad_set d m" let ?Q = "{q ∈ Q. Keys (set (fst q)) ∪ set (fst (snd (snd q))) ⊆ ?B}" from assms have "wfp_on (λx y. (x, y) ∈ sym_preproc_aux_term1 d) {x. set (fst (snd (snd x))) ⊆ ?B}" by (rule sym_preproc_aux_term1_wf_on) moreover from ‹x ∈ Q› A have "x ∈ ?Q" by simp moreover have "?Q ⊆ {x. set (fst (snd (snd x))) ⊆ ?B}" by auto ultimately obtain z where "z ∈ ?Q" and *: "⋀y. (y, z) ∈ sym_preproc_aux_term1 d ⟹ y ∉ ?Q" by (rule wfp_onE_min) blast from this(1) have "z ∈ Q" and "Keys (set (fst z)) ∪ set (fst (snd (snd z))) ⊆ ?B" by simp_all from this(2) have a: "pp_of_term ` (Keys (set (fst z)) ∪ set (fst (snd (snd z)))) ⊆ dgrad_set d m" by blast show "∃z∈Q. ∀y. (y, z) ∈ sym_preproc_aux_term d ⟶ y ∉ Q" proof (intro bexI allI impI) fix y assume "(y, z) ∈ sym_preproc_aux_term d" hence "(y, z) ∈ sym_preproc_aux_term1 d" and "(y, z) ∈ sym_preproc_aux_term2 d" by (simp_all add: sym_preproc_aux_term_def) from this(2) have "fst y = fst z" and "dgrad_set_le d (pp_of_term ` set (fst (snd (snd y)))) (pp_of_term ` (Keys (set (fst z)) ∪ set (fst (snd (snd z)))))" by (auto simp add: sym_preproc_aux_term2_def) from this(2) a have "pp_of_term ` (set (fst (snd (snd y)))) ⊆ dgrad_set d m" by (rule dgrad_set_le_dgrad_set) hence "Keys (set (fst y)) ∪ set (fst (snd (snd y))) ⊆ ?B" using a by (auto simp add: ‹fst y = fst z›) moreover from ‹(y, z) ∈ sym_preproc_aux_term1 d› have "y ∉ ?Q" by (rule *) ultimately show "y ∉ Q" by simp qed fact qed primrec sym_preproc_addnew :: "('t ⇒⇩0 'b::semiring_1) list ⇒ 't list ⇒ ('t ⇒⇩0 'b) list ⇒ 't ⇒ ('t list × ('t ⇒⇩0 'b) list)" where "sym_preproc_addnew [] vs fs _ = (vs, fs)"| "sym_preproc_addnew (g # gs) vs fs v = (if lt g adds⇩t v then (let f = monom_mult 1 (pp_of_term v - lp g) g in sym_preproc_addnew gs (merge_wrt (≻⇩t) vs (keys_to_list (tail f))) (insert_list f fs) v ) else sym_preproc_addnew gs vs fs v )" lemma fst_sym_preproc_addnew_less: assumes "⋀u. u ∈ set vs ⟹ u ≺⇩t v" and "u ∈ set (fst (sym_preproc_addnew gs vs fs v))" shows "u ≺⇩t v" using assms proof (induct gs arbitrary: fs vs) case Nil from Nil(2) have "u ∈ set vs" by simp thus ?case by (rule Nil(1)) next case (Cons g gs) from Cons(3) show ?case proof (simp add: Let_def split: if_splits) let ?t = "pp_of_term v - lp g" assume "lt g adds⇩t v" assume "u ∈ set (fst (sym_preproc_addnew gs (merge_wrt (≻⇩t) vs (keys_to_list (tail (monom_mult 1 ?t g)))) (insert_list (monom_mult 1 ?t g) fs) v))" with _ show ?thesis proof (rule Cons(1)) fix u assume "u ∈ set (merge_wrt (≻⇩t) vs (keys_to_list (tail (monom_mult 1 ?t g))))" hence "u ∈ set vs ∨ u ∈ keys (tail (monom_mult 1 ?t g))" by (simp add: set_merge_wrt keys_to_list_def set_pps_to_list) thus "u ≺⇩t v" proof assume "u ∈ set vs" thus ?thesis by (rule Cons(2)) next assume "u ∈ keys (tail (monom_mult 1 ?t g))" hence "u ≺⇩t lt (monom_mult 1 ?t g)" by (rule keys_tail_less_lt) also have "... ≼⇩t ?t ⊕ lt g" by (rule lt_monom_mult_le) also from ‹lt g adds⇩t v› have "... = v" by (metis add_diff_cancel_right' adds_termE pp_of_term_splus) finally show ?thesis . qed qed next assume "u ∈ set (fst (sym_preproc_addnew gs vs fs v))" with Cons(2) show ?thesis by (rule Cons(1)) qed qed lemma fst_sym_preproc_addnew_dgrad_set_le: assumes "dickson_grading d" shows "dgrad_set_le d (pp_of_term ` set (fst (sym_preproc_addnew gs vs fs v))) (pp_of_term ` (Keys (set gs) ∪ insert v (set vs)))" proof (induct gs arbitrary: fs vs) case Nil show ?case by (auto intro: dgrad_set_le_subset) next case (Cons g gs) show ?case proof (simp add: Let_def, intro conjI impI) assume "lt g adds⇩t v" let ?t = "pp_of_term v - lp g" let ?vs = "merge_wrt (≻⇩t) vs (keys_to_list (tail (monom_mult 1 ?t g)))" let ?fs = "insert_list (monom_mult 1 ?t g) fs" from Cons have "dgrad_set_le d (pp_of_term ` set (fst (sym_preproc_addnew gs ?vs ?fs v))) (pp_of_term ` (Keys (insert g (set gs)) ∪ insert v (set vs)))" proof (rule dgrad_set_le_trans) show "dgrad_set_le d (pp_of_term ` (Keys (set gs) ∪ insert v (set ?vs))) (pp_of_term ` (Keys (insert g (set gs)) ∪ insert v (set vs)))" unfolding dgrad_set_le_def set_merge_wrt set_keys_to_list proof (intro ballI) fix s assume "s ∈ pp_of_term ` (Keys (set gs) ∪ insert v (set vs ∪ keys (tail (monom_mult 1 ?t g))))" hence "s ∈ pp_of_term ` (Keys (set gs) ∪ insert v (set vs)) ∪ pp_of_term ` keys (tail (monom_mult 1 ?t g))" by auto thus "∃t ∈ pp_of_term ` (Keys (insert g (set gs)) ∪ insert v (set vs)). d s ≤ d t" proof assume "s ∈ pp_of_term ` (Keys (set gs) ∪ insert v (set vs))" thus ?thesis by (auto simp add: Keys_insert) next assume "s ∈ pp_of_term ` keys (tail (monom_mult 1 ?t g))" hence "s ∈ pp_of_term ` keys (monom_mult 1 ?t g)" by (auto simp add: keys_tail) from this keys_monom_mult_subset have "s ∈ pp_of_term ` (⊕) ?t ` keys g" by blast then obtain u where "u ∈ keys g" and s: "s = pp_of_term (?t ⊕ u)" by blast have "d s = d ?t ∨ d s = d (pp_of_term u)" unfolding s pp_of_term_splus using dickson_gradingD1[OF assms] by auto thus ?thesis proof from ‹lt g adds⇩t v› have "lp g adds pp_of_term v" by (simp add: adds_term_def) assume "d s = d ?t" also from assms ‹lp g adds pp_of_term v› have "... ≤ d (pp_of_term v)" by (rule dickson_grading_minus) finally show ?thesis by blast next assume "d s = d (pp_of_term u)" moreover from ‹u ∈ keys g› have "u ∈ Keys (insert g (set gs))" by (simp add: Keys_insert) ultimately show ?thesis by auto qed qed qed qed thus "dgrad_set_le d (pp_of_term ` set (fst (sym_preproc_addnew gs ?vs ?fs v))) (insert (pp_of_term v) (pp_of_term ` (Keys (insert g (set gs)) ∪ set vs)))" by simp next from Cons show "dgrad_set_le d (pp_of_term ` set (fst (sym_preproc_addnew gs vs fs v))) (insert (pp_of_term v) (pp_of_term ` (Keys (insert g (set gs)) ∪ set vs)))" proof (rule dgrad_set_le_trans) show "dgrad_set_le d (pp_of_term ` (Keys (set gs) ∪ insert v (set vs))) (insert (pp_of_term v) (pp_of_term ` (Keys (insert g (set gs)) ∪ set vs)))" by (rule dgrad_set_le_subset, auto simp add: Keys_def) qed qed qed lemma components_fst_sym_preproc_addnew_subset: "component_of_term ` set (fst (sym_preproc_addnew gs vs fs v)) ⊆ component_of_term ` (Keys (set gs) ∪ insert v (set vs))" proof (induct gs arbitrary: fs vs) case Nil show ?case by (auto intro: dgrad_set_le_subset) next case (Cons g gs) show ?case proof (simp add: Let_def, intro conjI impI) assume "lt g adds⇩t v" let ?t = "pp_of_term v - lp g" let ?vs = "merge_wrt (≻⇩t) vs (keys_to_list (tail (monom_mult 1 ?t g)))" let ?fs = "insert_list (monom_mult 1 ?t g) fs" from Cons have "component_of_term ` set (fst (sym_preproc_addnew gs ?vs ?fs v)) ⊆ component_of_term ` (Keys (insert g (set gs)) ∪ insert v (set vs))" proof (rule subset_trans) show "component_of_term ` (Keys (set gs) ∪ insert v (set ?vs)) ⊆ component_of_term ` (Keys (insert g (set gs)) ∪ insert v (set vs))" unfolding set_merge_wrt set_keys_to_list proof fix k assume "k ∈ component_of_term ` (Keys (set gs) ∪ insert v (set vs ∪ keys (tail (monom_mult 1 ?t g))))" hence "k ∈ component_of_term ` (Keys (set gs) ∪ insert v (set vs)) ∪ component_of_term ` keys (tail (monom_mult 1 ?t g))" by auto thus "k ∈ component_of_term ` (Keys (insert g (set gs)) ∪ insert v (set vs))" proof assume "k ∈ component_of_term ` (Keys (set gs) ∪ insert v (set vs))" thus ?thesis by (auto simp add: Keys_insert) next assume "k ∈ component_of_term ` keys (tail (monom_mult 1 ?t g))" hence "k ∈ component_of_term ` keys (monom_mult 1 ?t g)" by (auto simp add: keys_tail) from this keys_monom_mult_subset have "k ∈ component_of_term ` (⊕) ?t ` keys g" by blast also have "... ⊆ component_of_term ` keys g" using component_of_term_splus by fastforce finally show ?thesis by (simp add: image_Un Keys_insert) qed qed qed thus "component_of_term ` set (fst (sym_preproc_addnew gs ?vs ?fs v)) ⊆ insert (component_of_term v) (component_of_term ` (Keys (insert g (set gs)) ∪ set vs))" by simp next from Cons show "component_of_term ` set (fst (sym_preproc_addnew gs vs fs v)) ⊆ insert (component_of_term v) (component_of_term ` (Keys (insert g (set gs)) ∪ set vs))" proof (rule subset_trans) show "component_of_term ` (Keys (set gs) ∪ insert v (set vs)) ⊆ insert (component_of_term v) (component_of_term ` (Keys (insert g (set gs)) ∪ set vs))" by (auto simp add: Keys_def) qed qed qed lemma fst_sym_preproc_addnew_superset: "set vs ⊆ set (fst (sym_preproc_addnew gs vs fs v))" proof (induct gs arbitrary: vs fs) case Nil show ?case by simp next case (Cons g gs) show ?case proof (simp add: Let_def, intro conjI impI) let ?t = "pp_of_term v - lp g" define f where "f = monom_mult 1 ?t g" have "set vs ⊆ set (merge_wrt (≻⇩t) vs (keys_to_list (tail f)))" by (auto simp add: set_merge_wrt) thus "set vs ⊆ set (fst (sym_preproc_addnew gs (merge_wrt (≻⇩t) vs (keys_to_list (tail f))) (insert_list f fs) v))" using Cons by (rule subset_trans) next show "set vs ⊆ set (fst (sym_preproc_addnew gs vs fs v))" by (fact Cons) qed qed lemma snd_sym_preproc_addnew_superset: "set fs ⊆ set (snd (sym_preproc_addnew gs vs fs v))" proof (induct gs arbitrary: vs fs) case Nil show ?case by simp next case (Cons g gs) show ?case proof (simp add: Let_def, intro conjI impI) let ?t = "pp_of_term v - lp g" define f where "f = monom_mult 1 ?t g" have "set fs ⊆ set (insert_list f fs)" by (auto simp add: set_insert_list) thus "set fs ⊆ set (snd (sym_preproc_addnew gs (merge_wrt (≻⇩t) vs (keys_to_list (tail f))) (insert_list f fs) v))" using Cons by (rule subset_trans) next show "set fs ⊆ set (snd (sym_preproc_addnew gs vs fs v))" by (fact Cons) qed qed lemma in_snd_sym_preproc_addnewE: assumes "p ∈ set (snd (sym_preproc_addnew gs vs fs v))" assumes 1: "p ∈ set fs ⟹ thesis" assumes 2: "⋀g s. g ∈ set gs ⟹ p = monom_mult 1 s g ⟹ thesis" shows thesis using assms proof (induct gs arbitrary: vs fs thesis) case Nil from Nil(1) have "p ∈ set fs" by simp thus ?case by (rule Nil(2)) next case (Cons g gs) from Cons(2) show ?case proof (simp add: Let_def split: if_splits) define f where "f = monom_mult 1 (pp_of_term v - lp g) g" define ts' where "ts' = merge_wrt (≻⇩t) vs (keys_to_list (tail f))" define fs' where "fs' = insert_list f fs" assume "p ∈ set (snd (sym_preproc_addnew gs ts' fs' v))" thus ?thesis proof (rule Cons(1)) assume "p ∈ set fs'" hence "p = f ∨ p ∈ set fs" by (simp add: fs'_def set_insert_list) thus ?thesis proof assume "p = f" have "g ∈ set (g # gs)" by simp from this ‹p = f› show ?thesis unfolding f_def by (rule Cons(4)) next assume "p ∈ set fs" thus ?thesis by (rule Cons(3)) qed next fix h s assume "h ∈ set gs" hence "h ∈ set (g # gs)" by simp moreover assume "p = monom_mult 1 s h" ultimately show thesis by (rule Cons(4)) qed next assume "p ∈ set (snd (sym_preproc_addnew gs vs fs v))" moreover note Cons(3) moreover have "h ∈ set gs ⟹ p = monom_mult 1 s h ⟹ thesis" for h s proof - assume "h ∈ set gs" hence "h ∈ set (g # gs)" by simp moreover assume "p = monom_mult 1 s h" ultimately show thesis by (rule Cons(4)) qed ultimately show ?thesis by (rule Cons(1)) qed qed lemma sym_preproc_addnew_pmdl: "pmdl (set gs ∪ set (snd (sym_preproc_addnew gs vs fs v))) = pmdl (set gs ∪ set fs)" (is "pmdl (set gs ∪ ?l) = ?r") proof have "set gs ⊆ set gs ∪ set fs" by simp also have "... ⊆ ?r" by (fact pmdl.span_superset) finally have "set gs ⊆ ?r" . moreover have "?l ⊆ ?r" proof fix p assume "p ∈ ?l" thus "p ∈ ?r" proof (rule in_snd_sym_preproc_addnewE) assume "p ∈ set fs" hence "p ∈ set gs ∪ set fs" by simp thus ?thesis by (rule pmdl.span_base) next fix g s assume "g ∈ set gs" and p: "p = monom_mult 1 s g" from this(1) ‹set gs ⊆ ?r› have "g ∈ ?r" .. thus ?thesis unfolding p by (rule pmdl_closed_monom_mult) qed qed ultimately have "set gs ∪ ?l ⊆ ?r" by blast thus "pmdl (set gs ∪ ?l) ⊆ ?r" by (rule pmdl.span_subset_spanI) next from snd_sym_preproc_addnew_superset have "set gs ∪ set fs ⊆ set gs ∪ ?l" by blast thus "?r ⊆ pmdl (set gs ∪ ?l)" by (rule pmdl.span_mono) qed lemma Keys_snd_sym_preproc_addnew: "Keys (set (snd (sym_preproc_addnew gs vs fs v))) ∪ insert v (set vs) = Keys (set fs) ∪ insert v (set (fst (sym_preproc_addnew gs vs (fs::('t ⇒⇩0 'b::semiring_1_no_zero_divisors) list) v)))" proof (induct gs arbitrary: vs fs) case Nil show ?case by simp next case (Cons g gs) from Cons have eq: "insert v (Keys (set (snd (sym_preproc_addnew gs ts' fs' v))) ∪ set ts') = insert v (Keys (set fs') ∪ set (fst (sym_preproc_addnew gs ts' fs' v)))" for ts' fs' by simp show ?case proof (simp add: Let_def eq, rule) assume "lt g adds⇩t v" let ?t = "pp_of_term v - lp g" define f where "f = monom_mult 1 ?t g" define ts' where "ts' = merge_wrt (≻⇩t) vs (keys_to_list (tail f))" define fs' where "fs' = insert_list f fs" have "keys (tail f) = keys f - {v}" proof (cases "g = 0") case True hence "f = 0" by (simp add: f_def) thus ?thesis by simp next case False hence "lt f = ?t ⊕ lt g" by (simp add: f_def lt_monom_mult) also from ‹lt g adds⇩t v› have "... = v" by (metis add_diff_cancel_right' adds_termE pp_of_term_splus) finally show ?thesis by (simp add: keys_tail) qed hence ts': "set ts' = set vs ∪ (keys f - {v})" by (simp add: ts'_def set_merge_wrt set_keys_to_list) have fs': "set fs' = insert f (set fs)" by (simp add: fs'_def set_insert_list) hence "f ∈ set fs'" by simp from this snd_sym_preproc_addnew_superset have "f ∈ set (snd (sym_preproc_addnew gs ts' fs' v))" .. hence "keys f ⊆ Keys (set (snd (sym_preproc_addnew gs ts' fs' v)))" by (rule keys_subset_Keys) hence "insert v (Keys (set (snd (sym_preproc_addnew gs ts' fs' v))) ∪ set vs) = insert v (Keys (set (snd (sym_preproc_addnew gs ts' fs' v))) ∪ set ts')" by (auto simp add: ts') also have "... = insert v (Keys (set fs') ∪ set (fst (sym_preproc_addnew gs ts' fs' v)))" by (fact eq) also have "... = insert v (Keys (set fs) ∪ set (fst (sym_preproc_addnew gs ts' fs' v)))" proof - { fix u assume "u ≠ v" and "u ∈ keys f" hence "u ∈ set ts'" by (simp add: ts') from this fst_sym_preproc_addnew_superset have "u ∈ set (fst (sym_preproc_addnew gs ts' fs' v))" .. } thus ?thesis by (auto simp add: fs' Keys_insert) qed finally show "insert v (Keys (set (snd (sym_preproc_addnew gs ts' fs' v))) ∪ set vs) = insert v (Keys (set fs) ∪ set (fst (sym_preproc_addnew gs ts' fs' v)))" . qed qed lemma sym_preproc_addnew_complete: assumes "g ∈ set gs" and "lt g adds⇩t v" shows "monom_mult 1 (pp_of_term v - lp g) g ∈ set (snd (sym_preproc_addnew gs vs fs v))" using assms(1) proof (induct gs arbitrary: vs fs) case Nil thus ?case by simp next case (Cons h gs) let ?t = "pp_of_term v - lp g" show ?case proof (cases "h = g") case True show ?thesis proof (simp add: True assms(2) Let_def) define f where "f = monom_mult 1 ?t g" define ts' where "ts' = merge_wrt (≻⇩t) vs (keys_to_list (tail (monom_mult 1 ?t g)))" have "f ∈ set (insert_list f fs)" by (simp add: set_insert_list) with snd_sym_preproc_addnew_superset show "f ∈ set (snd (sym_preproc_addnew gs ts' (insert_list f fs) v))" .. qed next case False with Cons(2) have "g ∈ set gs" by simp hence *: "monom_mult 1 ?t g ∈ set (snd (sym_preproc_addnew gs ts' fs' v))" for ts' fs' by (rule Cons(1)) show ?thesis by (simp add: Let_def *) qed qed function sym_preproc_aux :: "('t ⇒⇩0 'b::semiring_1) list ⇒ 't list ⇒ ('t list × ('t ⇒⇩0 'b) list) ⇒ ('t list × ('t ⇒⇩0 'b) list)" where "sym_preproc_aux gs ks (vs, fs) = (if vs = [] then (ks, fs) else let v = ord_term_lin.max_list vs; vs' = removeAll v vs in sym_preproc_aux gs (ks @ [v]) (sym_preproc_addnew gs vs' fs v) )" by pat_completeness auto termination proof - from ex_dgrad obtain d::"'a ⇒ nat" where dg: "dickson_grading d" .. let ?R = "(sym_preproc_aux_term d)::((('t ⇒⇩0 'b) list × 't list × 't list × ('t ⇒⇩0 'b) list) × ('t ⇒⇩0 'b) list × 't list × 't list × ('t ⇒⇩0 'b) list) set" show ?thesis proof from dg show "wf ?R" by (rule sym_preproc_aux_term_wf) next fix gs::"('t ⇒⇩0 'b) list" and ks vs fs v vs' assume "vs ≠ []" and "v = ord_term_lin.max_list vs" and vs': "vs' = removeAll v vs" from this(1, 2) have v: "v = ord_term_lin.Max (set vs)" by (simp add: ord_term_lin.max_list_Max) obtain vs0 fs0 where eq: "sym_preproc_addnew gs vs' fs v = (vs0, fs0)" by fastforce show "((gs, ks @ [v], sym_preproc_addnew gs vs' fs v), (gs, ks, vs, fs)) ∈ ?R" proof (simp add: eq sym_preproc_aux_term_def sym_preproc_aux_term1_def sym_preproc_aux_term2_def, intro conjI bexI ballI) fix w assume "w ∈ set vs0" show "w ≺⇩t v" proof (rule fst_sym_preproc_addnew_less) fix u assume "u ∈ set vs'" thus "u ≺⇩t v" unfolding vs' v set_removeAll using ord_term_lin.antisym_conv1 by fastforce next from ‹w ∈ set vs0› show "w ∈ set (fst (sym_preproc_addnew gs vs' fs v))" by (simp add: eq) qed next from ‹vs ≠ []› show "v ∈ set vs" by (simp add: v) next from dg have "dgrad_set_le d (pp_of_term ` set (fst (sym_preproc_addnew gs vs' fs v))) (pp_of_term ` (Keys (set gs) ∪ insert v (set vs')))" by (rule fst_sym_preproc_addnew_dgrad_set_le) moreover have "insert v (set vs') = set vs" by (auto simp add: vs' v ‹vs ≠ []›) ultimately show "dgrad_set_le d (pp_of_term ` set vs0) (pp_of_term ` (Keys (set gs) ∪ set vs))" by (simp add: eq) qed qed qed lemma sym_preproc_aux_Nil: "sym_preproc_aux gs ks ([], fs) = (ks, fs)" by simp lemma sym_preproc_aux_sorted: assumes "sorted_wrt (≻⇩t) (v # vs)" shows "sym_preproc_aux gs ks (v # vs, fs) = sym_preproc_aux gs (ks @ [v]) (sym_preproc_addnew gs vs fs v)" proof - from assms have *: "u ∈ set vs ⟹ u ≺⇩t v" for u by simp have "ord_term_lin.max_list (v # vs) = ord_term_lin.Max (set (v # vs))" by (simp add: ord_term_lin.max_list_Max del: ord_term_lin.max_list.simps) also have "... = v" proof (rule ord_term_lin.Max_eqI) fix s assume "s ∈ set (v # vs)" hence "s = v ∨ s ∈ set vs" by simp thus "s ≼⇩t v" proof assume "s = v" thus ?thesis by simp next assume "s ∈ set vs" hence "s ≺⇩t v" by (rule *) thus ?thesis by simp qed next show "v ∈ set (v # vs)" by simp qed rule finally have eq1: "ord_term_lin.max_list (v # vs) = v" . have eq2: "removeAll v (v # vs) = vs" proof (simp, rule removeAll_id, rule) assume "v ∈ set vs" hence "v ≺⇩t v" by (rule *) thus False .. qed show ?thesis by (simp only: sym_preproc_aux.simps eq1 eq2 Let_def, simp) qed lemma sym_preproc_aux_induct [consumes 0, case_names base rec]: assumes base: "⋀ks fs. P ks [] fs (ks, fs)" and rec: "⋀ks vs fs v vs'. vs ≠ [] ⟹ v = ord_term_lin.Max (set vs) ⟹ vs' = removeAll v vs ⟹ P (ks @ [v]) (fst (sym_preproc_addnew gs vs' fs v)) (snd (sym_preproc_addnew gs vs' fs v)) (sym_preproc_aux gs (ks @ [v]) (sym_preproc_addnew gs vs' fs v)) ⟹ P ks vs fs (sym_preproc_aux gs (ks @ [v]) (sym_preproc_addnew gs vs' fs v))" shows "P ks vs fs (sym_preproc_aux gs ks (vs, fs))" proof - from ex_dgrad obtain d::"'a ⇒ nat" where dg: "dickson_grading d" .. let ?R = "(sym_preproc_aux_term d)::((('t ⇒⇩0 'b) list × 't list × 't list × ('t ⇒⇩0 'b) list) × ('t ⇒⇩0 'b) list × 't list × 't list × ('t ⇒⇩0 'b) list) set" define args where "args = (gs, ks, vs, fs)" from dg have "wf ?R" by (rule sym_preproc_aux_term_wf) hence "fst args = gs ⟹ P (fst (snd args)) (fst (snd (snd args))) (snd (snd (snd args))) (sym_preproc_aux gs (fst (snd args)) (snd (snd args)))" proof induct fix x assume IH': "⋀y. (y, x) ∈ sym_preproc_aux_term d ⟹ fst y = gs ⟹ P (fst (snd y)) (fst (snd (snd y))) (snd (snd (snd y))) (sym_preproc_aux gs (fst (snd y)) (snd (snd y)))" assume "fst x = gs" then obtain x0 where x: "x = (gs, x0)" by (meson eq_fst_iff) obtain ks x1 where x0: "x0 = (ks, x1)" by (meson case_prodE case_prodI2) obtain vs fs where x1: "x1 = (vs, fs)" by (meson case_prodE case_prodI2) from IH' have IH: "⋀ks' n. ((gs, ks', n), (gs, ks, vs, fs)) ∈ sym_preproc_aux_term d ⟹ P ks' (fst n) (snd n) (sym_preproc_aux gs ks' n)" unfolding x x0 x1 by fastforce show "P (fst (snd x)) (fst (snd (snd x))) (snd (snd (snd x))) (sym_preproc_aux gs (fst (snd x)) (snd (snd x)))" proof (simp add: x x0 x1 Let_def, intro conjI impI) show "P ks [] fs (ks, fs)" by (fact base) next assume "vs ≠ []" define v where "v = ord_term_lin.max_list vs" from ‹vs ≠ []› have v_alt: "v = ord_term_lin.Max (set vs)" unfolding v_def by (rule ord_term_lin.max_list_Max) define vs' where "vs' = removeAll v vs" show "P ks vs fs (sym_preproc_aux gs (ks @ [v]) (sym_preproc_addnew gs vs' fs v))" proof (rule rec, fact ‹vs ≠ []›, fact v_alt, fact vs'_def) let ?n = "sym_preproc_addnew gs vs' fs v" obtain vs0 fs0 where eq: "?n = (vs0, fs0)" by fastforce show "P (ks @ [v]) (fst ?n) (snd ?n) (sym_preproc_aux gs (ks @ [v]) ?n)" proof (rule IH, simp add: eq sym_preproc_aux_term_def sym_preproc_aux_term1_def sym_preproc_aux_term2_def, intro conjI bexI ballI) fix s assume "s ∈ set vs0" show "s ≺⇩t v" proof (rule fst_sym_preproc_addnew_less) fix u assume "u ∈ set vs'" thus "u ≺⇩t v" unfolding vs'_def v_alt set_removeAll using ord_term_lin.antisym_conv1 by fastforce next from ‹s ∈ set vs0› show "s ∈ set (fst (sym_preproc_addnew gs vs' fs v))" by (simp add: eq) qed next from ‹vs ≠ []› show "v ∈ set vs" by (simp add: v_alt) next from dg have "dgrad_set_le d (pp_of_term ` set (fst (sym_preproc_addnew gs vs' fs v))) (pp_of_term ` (Keys (set gs) ∪ insert v (set vs')))" by (rule fst_sym_preproc_addnew_dgrad_set_le) moreover have "insert v (set vs') = set vs" by (auto simp add: vs'_def v_alt ‹vs ≠ []›) ultimately show "dgrad_set_le d (pp_of_term ` set vs0) (pp_of_term ` (Keys (set gs) ∪ set vs))" by (simp add: eq) qed qed qed qed thus ?thesis by (simp add: args_def) qed lemma fst_sym_preproc_aux_sorted_wrt: assumes "sorted_wrt (≻⇩t) ks" and "⋀k v. k ∈ set ks ⟹ v ∈ set vs ⟹ v ≺⇩t k" shows "sorted_wrt (≻⇩t) (fst (sym_preproc_aux gs ks (vs, fs)))" using assms proof (induct gs ks vs fs rule: sym_preproc_aux_induct) case (base ks fs) from base(1) show ?case by simp next case (rec ks vs fs v vs') from rec(1) have "v ∈ set vs" by (simp add: rec(2)) from rec(1) have *: "⋀u. u ∈ set vs' ⟹ u ≺⇩t v" unfolding rec(2, 3) set_removeAll using ord_term_lin.antisym_conv3 by force show ?case proof (rule rec(4)) show "sorted_wrt (≻⇩t) (ks @ [v])" proof (simp add: sorted_wrt_append rec(5), rule) fix k assume "k ∈ set ks" from this ‹v ∈ set vs› show "v ≺⇩t k" by (rule rec(6)) qed next fix k u assume "k ∈ set (ks @ [v])" and "u ∈ set (fst (sym_preproc_addnew gs vs' fs v))" from * this(2) have "u ≺⇩t v" by (rule fst_sym_preproc_addnew_less) from ‹k ∈ set (ks @ [v])› have "k ∈ set ks ∨ k = v" by auto thus "u ≺⇩t k" proof assume "k ∈ set ks" from this ‹v ∈ set vs› have "v ≺⇩t k" by (rule rec(6)) with ‹u ≺⇩t v› show ?thesis by simp next assume "k = v" with ‹u ≺⇩t v› show ?thesis by simp qed qed qed lemma fst_sym_preproc_aux_complete: assumes "Keys (set (fs::('t ⇒⇩0 'b::semiring_1_no_zero_divisors) list)) = set ks ∪ set vs" shows "set (fst (sym_preproc_aux gs ks (vs, fs))) = Keys (set (snd (sym_preproc_aux gs ks (vs, fs))))" using assms proof (induct gs ks vs fs rule: sym_preproc_aux_induct) case (base ks fs) thus ?case by simp next case (rec ks vs fs v vs') from rec(1) have "v ∈ set vs" by (simp add: rec(2)) hence eq: "insert v (set vs') = set vs" by (auto simp add: rec(3)) also from rec(5) have "... ⊆ Keys (set fs)" by simp also from snd_sym_preproc_addnew_superset have "... ⊆ Keys (set (snd (sym_preproc_addnew gs vs' fs v)))" by (rule Keys_mono) finally have "... = ... ∪ (insert v (set vs'))" by blast also have "... = Keys (set fs) ∪ insert v (set (fst (sym_preproc_addnew gs vs' fs v)))" by (fact Keys_snd_sym_preproc_addnew) also have "... = (set ks ∪ (insert v (set vs'))) ∪ (insert v (set (fst (sym_preproc_addnew gs vs' fs v))))" by (simp only: rec(5) eq) also have "... = set (ks @ [v]) ∪ (set vs' ∪ set (fst (sym_preproc_addnew gs vs' fs v)))" by auto also from fst_sym_preproc_addnew_superset have "... = set (ks @ [v]) ∪ set (fst (sym_preproc_addnew gs vs' fs v))" by blast finally show ?case by (rule rec(4)) qed lemma snd_sym_preproc_aux_superset: "set fs ⊆ set (snd (sym_preproc_aux gs ks (vs, fs)))" proof (induct fs rule: sym_preproc_aux_induct) case (base ks fs) show ?case by simp next case (rec ks vs fs v vs') from snd_sym_preproc_addnew_superset rec(4) show ?case by (rule subset_trans) qed lemma in_snd_sym_preproc_auxE: assumes "p ∈ set (snd (sym_preproc_aux gs ks (vs, fs)))" assumes 1: "p ∈ set fs ⟹ thesis" assumes 2: "⋀g t. g ∈ set gs ⟹ p = monom_mult 1 t g ⟹ thesis" shows thesis using assms proof (induct gs ks vs fs arbitrary: thesis rule: sym_preproc_aux_induct) case (base ks fs) from base(1) have "p ∈ set fs" by simp thus ?case by (rule base(2)) next case (rec ks vs fs v vs') from rec(5) show ?case proof (rule rec(4)) assume "p ∈ set (snd (sym_preproc_addnew gs vs' fs v))" thus ?thesis proof (rule in_snd_sym_preproc_addnewE) assume "p ∈ set fs" thus ?thesis by (rule rec(6)) next fix g s assume "g ∈ set gs" and "p = monom_mult 1 s g" thus ?thesis by (rule rec(7)) qed next fix g t assume "g ∈ set gs" and "p = monom_mult 1 t g" thus ?thesis by (rule rec(7)) qed qed lemma snd_sym_preproc_aux_pmdl: "pmdl (set gs ∪ set (snd (sym_preproc_aux gs ks (ts, fs)))) = pmdl (set gs ∪ set fs)" proof (induct fs rule: sym_preproc_aux_induct) case (base ks fs) show ?case by simp next case (rec ks vs fs v vs') from rec(4) sym_preproc_addnew_pmdl show ?case by (rule trans) qed lemma snd_sym_preproc_aux_dgrad_set_le: assumes "dickson_grading d" and "set vs ⊆ Keys (set (fs::('t ⇒⇩0 'b::semiring_1_no_zero_divisors) list))" shows "dgrad_set_le d (pp_of_term ` Keys (set (snd (sym_preproc_aux gs ks (vs, fs))))) (pp_of_term ` Keys (set gs ∪ set fs))" using assms(2) proof (induct fs rule: sym_preproc_aux_induct) case (base ks fs) show ?case by (rule dgrad_set_le_subset, simp add: Keys_Un image_Un) next case (rec ks vs fs v vs') let ?n = "sym_preproc_addnew gs vs' fs v" from rec(1) have "v ∈ set vs" by (simp add: rec(2)) hence set_vs: "insert v (set vs') = set vs" by (auto simp add: rec(3)) from rec(5) have eq: "Keys (set fs) ∪ (Keys (set gs) ∪ set vs) = Keys (set gs) ∪ Keys (set fs)" by blast have "dgrad_set_le d (pp_of_term ` Keys (set (snd (sym_preproc_aux gs (ks @ [v]) ?n)))) (pp_of_term ` Keys (set gs ∪ set (snd ?n)))" proof (rule rec(4)) have "set (fst ?n) ⊆ Keys (set (snd ?n)) ∪ insert v (set vs')" by (simp only: Keys_snd_sym_preproc_addnew, blast) also have "... = Keys (set (snd ?n)) ∪ (set vs)" by (simp only: set_vs) also have "... ⊆ Keys (set (snd ?n))" proof - { fix u assume "u ∈ set vs" with rec(5) have "u ∈ Keys (set fs)" .. then obtain f where "f ∈ set fs" and "u ∈ keys f" by (rule in_KeysE) from this(1) snd_sym_preproc_addnew_superset have "f ∈ set (snd ?n)" .. with ‹u ∈ keys f› have "u ∈ Keys (set (snd ?n))" by (rule in_KeysI) } thus ?thesis by auto qed finally show "set (fst ?n) ⊆ Keys (set (snd ?n))" . qed also have "dgrad_set_le d ... (pp_of_term ` Keys (set gs ∪ set fs))" proof (simp only: image_Un Keys_Un dgrad_set_le_Un, rule) show "dgrad_set_le d (pp_of_term ` Keys (set gs)) (pp_of_term ` Keys (set gs) ∪ pp_of_term ` Keys (set fs))" by (rule dgrad_set_le_subset, simp) next have "dgrad_set_le d (pp_of_term ` Keys (set (snd ?n))) (pp_of_term ` (Keys (set fs) ∪ insert v (set (fst ?n))))" by (rule dgrad_set_le_subset, auto simp only: Keys_snd_sym_preproc_addnew[symmetric]) also have "dgrad_set_le d ... (pp_of_term ` Keys (set fs) ∪ pp_of_term ` (Keys (set gs) ∪ insert v (set vs')))" proof (simp only: dgrad_set_le_Un image_Un, rule) show "dgrad_set_le d (pp_of_term ` Keys (set fs)) (pp_of_term ` Keys (set fs) ∪ (pp_of_term ` Keys (set gs) ∪ pp_of_term ` insert v (set vs')))" by (rule dgrad_set_le_subset, blast) next have "dgrad_set_le d (pp_of_term ` {v}) (pp_of_term ` (Keys (set gs) ∪ insert v (set vs')))" by (rule dgrad_set_le_subset, simp) moreover from assms(1) have "dgrad_set_le d (pp_of_term ` set (fst ?n)) (pp_of_term ` (Keys (set gs) ∪ insert v (set vs')))" by (rule fst_sym_preproc_addnew_dgrad_set_le) ultimately have "dgrad_set_le d (pp_of_term ` ({v} ∪ set (fst ?n))) (pp_of_term ` (Keys (set gs) ∪ insert v (set vs')))" by (simp only: dgrad_set_le_Un image_Un) also have "dgrad_set_le d (pp_of_term ` (Keys (set gs) ∪ insert v (set vs'))) (pp_of_term ` (Keys (set fs) ∪ (Keys (set gs) ∪ insert v (set vs'))))" by (rule dgrad_set_le_subset, blast) finally show "dgrad_set_le d (pp_of_term ` insert v (set (fst ?n))) (pp_of_term ` Keys (set fs) ∪ (pp_of_term ` Keys (set gs) ∪ pp_of_term ` insert v (set vs')))" by (simp add: image_Un) qed finally show "dgrad_set_le d (pp_of_term ` Keys (set (snd ?n))) (pp_of_term ` Keys (set gs) ∪ pp_of_term ` Keys (set fs))" by (simp only: set_vs eq, metis eq image_Un) qed finally show ?case . qed lemma components_snd_sym_preproc_aux_subset: assumes "set vs ⊆ Keys (set (fs::('t ⇒⇩0 'b::semiring_1_no_zero_divisors) list))" shows "component_of_term ` Keys (set (snd (sym_preproc_aux gs ks (vs, fs)))) ⊆ component_of_term ` Keys (set gs ∪ set fs)" using assms proof (induct fs rule: sym_preproc_aux_induct) case (base ks fs) show ?case by (simp add: Keys_Un image_Un) next case (rec ks vs fs v vs') let ?n = "sym_preproc_addnew gs vs' fs v" from rec(1) have "v ∈ set vs" by (simp add: rec(2)) hence set_vs: "insert v (set vs') = set vs" by (auto simp add: rec(3)) from rec(5) have eq: "Keys (set fs) ∪ (Keys (set gs) ∪ set vs) = Keys (set gs) ∪ Keys (set fs)" by blast have "component_of_term ` Keys (set (snd (sym_preproc_aux gs (ks @ [v]) ?n))) ⊆ component_of_term ` Keys (set gs ∪ set (snd ?n))" proof (rule rec(4)) have "set (fst ?n) ⊆ Keys (set (snd ?n)) ∪ insert v (set vs')" by (simp only: Keys_snd_sym_preproc_addnew, blast) also have "... = Keys (set (snd ?n)) ∪ (set vs)" by (simp only: set_vs) also have "... ⊆ Keys (set (snd ?n))" proof - { fix u assume "u ∈ set vs" with rec(5) have "u ∈ Keys (set fs)" .. then obtain f where "f ∈ set fs" and "u ∈ keys f" by (rule in_KeysE) from this(1) snd_sym_preproc_addnew_superset have "f ∈ set (snd ?n)" .. with ‹u ∈ keys f› have "u ∈ Keys (set (snd ?n))" by (rule in_KeysI) } thus ?thesis by auto qed finally show "set (fst ?n) ⊆ Keys (set (snd ?n))" . qed also have "... ⊆ component_of_term ` Keys (set gs ∪ set fs)" proof (simp only: image_Un Keys_Un Un_subset_iff, rule, fact Un_upper1) have "component_of_term ` Keys (set (snd ?n)) ⊆ component_of_term ` (Keys (set fs) ∪ insert v (set (fst ?n)))" by (auto simp only: Keys_snd_sym_preproc_addnew[symmetric]) also have "... ⊆ component_of_term ` Keys (set fs) ∪ component_of_term ` (Keys (set gs) ∪ insert v (set vs'))" proof (simp only: Un_subset_iff image_Un, rule, fact Un_upper1) have "component_of_term ` {v} ⊆ component_of_term ` (Keys (set gs) ∪ insert v (set vs'))" by simp moreover have "component_of_term ` set (fst ?n) ⊆ component_of_term ` (Keys (set gs) ∪ insert v (set vs'))" by (rule components_fst_sym_preproc_addnew_subset) ultimately have "component_of_term ` ({v} ∪ set (fst ?n)) ⊆ component_of_term ` (Keys (set gs) ∪ insert v (set vs'))" by (simp only: Un_subset_iff image_Un) also have "component_of_term ` (Keys (set gs) ∪ insert v (set vs')) ⊆ component_of_term ` (Keys (set fs) ∪ (Keys (set gs) ∪ insert v (set vs')))" by blast finally show "component_of_term ` insert v (set (fst ?n)) ⊆ component_of_term ` Keys (set fs) ∪ (component_of_term ` Keys (set gs) ∪ component_of_term ` insert v (set vs'))" by (simp add: image_Un) qed finally show "component_of_term ` Keys (set (snd ?n)) ⊆ component_of_term ` Keys (set gs) ∪ component_of_term ` Keys (set fs)" by (simp only: set_vs eq, metis eq image_Un) qed finally show ?case . qed lemma snd_sym_preproc_aux_complete: assumes "⋀u' g'. u' ∈ Keys (set fs) ⟹ u' ∉ set vs ⟹ g' ∈ set gs ⟹ lt g' adds⇩t u' ⟹ monom_mult 1 (pp_of_term u' - lp g') g' ∈ set fs" assumes "u ∈ Keys (set (snd (sym_preproc_aux gs ks (vs, fs))))" and "g ∈ set gs" and "lt g adds⇩t u" shows "monom_mult (1::'b::semiring_1_no_zero_divisors) (pp_of_term u - lp g) g ∈ set (snd (sym_preproc_aux gs ks (vs, fs)))" using assms proof (induct fs rule: sym_preproc_aux_induct) case (base ks fs) from base(2) have "u ∈ Keys (set fs)" by simp from this _ base(3, 4) have "monom_mult 1 (pp_of_term u - lp g) g ∈ set fs" proof (rule base(1)) show "u ∉ set []" by simp qed thus ?case by simp next case (rec ks vs fs v vs') from rec(1) have "v ∈ set vs" by (simp add: rec(2)) hence set_ts: "set vs = insert v (set vs')" by (auto simp add: rec(3)) let ?n = "sym_preproc_addnew gs vs' fs v" from _ rec(6, 7, 8) show ?case proof (rule rec(4)) fix v' g' assume "v' ∈ Keys (set (snd ?n))" and "v' ∉ set (fst ?n)" and "g' ∈ set gs" and "lt g' adds⇩t v'" from this(1) Keys_snd_sym_preproc_addnew have "v' ∈ Keys (set fs) ∪ insert v (set (fst ?n))" by blast with ‹v' ∉ set (fst ?n)› have disj: "v' ∈ Keys (set fs) ∨ v' = v" by blast show "monom_mult 1 (pp_of_term v' - lp g') g' ∈ set (snd ?n)" proof (cases "v' = v") case True from ‹g' ∈ set gs› ‹lt g' adds⇩t v'› show ?thesis unfolding True by (rule sym_preproc_addnew_complete) next case False with disj have "v' ∈ Keys (set fs)" by simp moreover have "v' ∉ set vs" proof assume "v' ∈ set vs" hence "v' ∈ set vs'" using False by (simp add: rec(3)) with fst_sym_preproc_addnew_superset have "v' ∈ set (fst ?n)" .. with ‹v' ∉ set (fst ?n)› show False .. qed ultimately have "monom_mult 1 (pp_of_term v' - lp g') g' ∈ set fs" using ‹g' ∈ set gs› ‹lt g' adds⇩t v'› by (rule rec(5)) with snd_sym_preproc_addnew_superset show ?thesis .. qed qed qed definition sym_preproc :: "('t ⇒⇩0 'b::semiring_1) list ⇒ ('t ⇒⇩0 'b) list ⇒ ('t list × ('t ⇒⇩0 'b) list)" where "sym_preproc gs fs = sym_preproc_aux gs [] (Keys_to_list fs, fs)" lemma sym_preproc_Nil [simp]: "sym_preproc gs [] = ([], [])" by (simp add: sym_preproc_def) lemma fst_sym_preproc: "fst (sym_preproc gs fs) = Keys_to_list (snd (sym_preproc gs (fs::('t ⇒⇩0 'b::semiring_1_no_zero_divisors) list)))" proof - let ?a = "fst (sym_preproc gs fs)" let ?b = "Keys_to_list (snd (sym_preproc gs fs))" have "antisymp (≻⇩t)" unfolding antisymp_def by fastforce have "irreflp (≻⇩t)" by (simp add: irreflp_def) moreover have "transp (≻⇩t)" unfolding transp_def by fastforce moreover have s1: "sorted_wrt (≻⇩t) ?a" unfolding sym_preproc_def by (rule fst_sym_preproc_aux_sorted_wrt, simp_all) ultimately have d1: "distinct ?a" by (rule distinct_sorted_wrt_irrefl) have s2: "sorted_wrt (≻⇩t) ?b" by (fact Keys_to_list_sorted_wrt) with ‹irreflp (≻⇩t)› ‹transp (≻⇩t)› have d2: "distinct ?b" by (rule distinct_sorted_wrt_irrefl) from ‹antisymp (≻⇩t)› s1 d1 s2 d2 show ?thesis proof (rule sorted_wrt_distinct_set_unique) show "set ?a = set ?b" unfolding set_Keys_to_list sym_preproc_def by (rule fst_sym_preproc_aux_complete, simp add: set_Keys_to_list) qed qed lemma snd_sym_preproc_superset: "set fs ⊆ set (snd (sym_preproc gs fs))" by (simp only: sym_preproc_def snd_conv, fact snd_sym_preproc_aux_superset) lemma in_snd_sym_preprocE: assumes "p ∈ set (snd (sym_preproc gs fs))" assumes 1: "p ∈ set fs ⟹ thesis" assumes 2: "⋀g t. g ∈ set gs ⟹ p = monom_mult 1 t g ⟹ thesis" shows thesis using assms unfolding sym_preproc_def snd_conv by (rule in_snd_sym_preproc_auxE) lemma snd_sym_preproc_pmdl: "pmdl (set gs ∪ set (snd (sym_preproc gs fs))) = pmdl (set gs ∪ set fs)" unfolding sym_preproc_def snd_conv by (fact snd_sym_preproc_aux_pmdl) lemma snd_sym_preproc_dgrad_set_le: assumes "dickson_grading d" shows "dgrad_set_le d (pp_of_term ` Keys (set (snd (sym_preproc gs fs)))) (pp_of_term ` Keys (set gs ∪ set (fs::('t ⇒⇩0 'b::semiring_1_no_zero_divisors) list)))" unfolding sym_preproc_def snd_conv using assms proof (rule snd_sym_preproc_aux_dgrad_set_le) show "set (Keys_to_list fs) ⊆ Keys (set fs)" by (simp add: set_Keys_to_list) qed corollary snd_sym_preproc_dgrad_p_set_le: assumes "dickson_grading d" shows "dgrad_p_set_le d (set (snd (sym_preproc gs fs))) (set gs ∪ set (fs::('t ⇒⇩0 'b::semiring_1_no_zero_divisors) list))" unfolding dgrad_p_set_le_def proof - from assms show "dgrad_set_le d (pp_of_term ` Keys (set (snd (sym_preproc gs fs)))) (pp_of_term ` Keys (set gs ∪ set fs))" by (rule snd_sym_preproc_dgrad_set_le) qed lemma components_snd_sym_preproc_subset: "component_of_term ` Keys (set (snd (sym_preproc gs fs))) ⊆ component_of_term ` Keys (set gs ∪ set (fs::('t ⇒⇩0 'b::semiring_1_no_zero_divisors) list))" unfolding sym_preproc_def snd_conv by (rule components_snd_sym_preproc_aux_subset, simp add: set_Keys_to_list) lemma snd_sym_preproc_complete: assumes "v ∈ Keys (set (snd (sym_preproc gs fs)))" and "g ∈ set gs" and "lt g adds⇩t v" shows "monom_mult (1::'b::semiring_1_no_zero_divisors) (pp_of_term v - lp g) g ∈ set (snd (sym_preproc gs fs))" using _ assms unfolding sym_preproc_def snd_conv proof (rule snd_sym_preproc_aux_complete) fix u' and g'::"'t ⇒⇩0 'b" assume "u' ∈ Keys (set fs)" and "u' ∉ set (Keys_to_list fs)" thus "monom_mult 1 (pp_of_term u' - lp g') g' ∈ set fs" by (simp add: set_Keys_to_list) qed end (* gd_term *) subsection ‹‹lin_red›› context ordered_term begin definition lin_red :: "('t ⇒⇩0 'b::field) set ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b) ⇒ bool" where "lin_red F p q ≡ (∃f∈F. red_single p q f 0)" text ‹@{const lin_red} is a restriction of @{const red}, where the reductor (‹f›) may only be multiplied by a constant factor, i.\,e. where the power-product is ‹0›.› lemma lin_redI: assumes "f ∈ F" and "red_single p q f 0" shows "lin_red F p q" unfolding lin_red_def using assms .. lemma lin_redE: assumes "lin_red F p q" obtains f::"'t ⇒⇩0 'b::field" where "f ∈ F" and "red_single p q f 0" proof - from assms obtain f where "f ∈ F" and t: "red_single p q f 0" unfolding lin_red_def by blast thus "?thesis" .. qed lemma lin_red_imp_red: assumes "lin_red F p q" shows "red F p q" proof - from assms obtain f where "f ∈ F" and "red_single p q f 0" by (rule lin_redE) thus ?thesis by (rule red_setI) qed lemma lin_red_Un: "lin_red (F ∪ G) p q = (lin_red F p q ∨ lin_red G p q)" proof assume "lin_red (F ∪ G) p q" then obtain f where "f ∈ F ∪ G" and r: "red_single p q f 0" by (rule lin_redE) from this(1) show "lin_red F p q ∨ lin_red G p q" proof assume "f ∈ F" from this r have "lin_red F p q" by (rule lin_redI) thus ?thesis .. next assume "f ∈ G" from this r have "lin_red G p q" by (rule lin_redI) thus ?thesis .. qed next assume "lin_red F p q ∨ lin_red G p q" thus "lin_red (F ∪ G) p q" proof assume "lin_red F p q" then obtain f where "f ∈ F" and r: "red_single p q f 0" by (rule lin_redE) from this(1) have "f ∈ F ∪ G" by simp from this r show ?thesis by (rule lin_redI) next assume "lin_red G p q" then obtain g where "g ∈ G" and r: "red_single p q g 0" by (rule lin_redE) from this(1) have "g ∈ F ∪ G" by simp from this r show ?thesis by (rule lin_redI) qed qed lemma lin_red_imp_red_rtrancl: assumes "(lin_red F)⇧*⇧* p q" shows "(red F)⇧*⇧* p q" using assms proof induct case base show ?case .. next case (step y z) from step(2) have "red F y z" by (rule lin_red_imp_red) with step(3) show ?case .. qed lemma phull_closed_lin_red: assumes "phull B ⊆ phull A" and "p ∈ phull A" and "lin_red B p q" shows "q ∈ phull A" proof - from assms(3) obtain f where "f ∈ B" and "red_single p q f 0" by (rule lin_redE) hence q: "q = p - (lookup p (lt f) / lc f) ⋅ f" by (simp add: red_single_def term_simps map_scale_eq_monom_mult) have "q - p ∈ phull B" by (simp add: q, rule phull.span_neg, rule phull.span_scale, rule phull.span_base, fact ‹f ∈ B›) with assms(1) have "q - p ∈ phull A" .. from this assms(2) have "(q - p) + p ∈ phull A" by (rule phull.span_add) thus ?thesis by simp qed subsection ‹Reduction› definition Macaulay_red :: "'t list ⇒ ('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b::field) list" where "Macaulay_red vs fs = (let lts = map lt (filter (λp. p ≠ 0) fs) in filter (λp. p ≠ 0 ∧ lt p ∉ set lts) (mat_to_polys vs (row_echelon (polys_to_mat vs fs))) )" text ‹‹Macaulay_red vs fs› auto-reduces (w.\,r.\,t. @{const lin_red}) the given list ‹fs› and returns those non-zero polynomials whose leading terms are not in ‹lt_set (set fs)›. Argument ‹vs› is expected to be ‹Keys_to_list fs›; this list is passed as an argument to @{const Macaulay_red}, because it can be efficiently computed by symbolic preprocessing.› lemma Macaulay_red_alt: "Macaulay_red (Keys_to_list fs) fs = filter (λp. lt p ∉ lt_set (set fs)) (Macaulay_list fs)" proof - have "{x ∈ set fs. x ≠ 0} = set fs - {0}" by blast thus ?thesis by (simp add: Macaulay_red_def Macaulay_list_def Macaulay_mat_def lt_set_def Let_def) qed lemma set_Macaulay_red: "set (Macaulay_red (Keys_to_list fs) fs) = set (Macaulay_list fs) - {p. lt p ∈ lt_set (set fs)}" by (auto simp add: Macaulay_red_alt) lemma Keys_Macaulay_red: "Keys (set (Macaulay_red (Keys_to_list fs) fs)) ⊆ Keys (set fs)" proof - have "Keys (set (Macaulay_red (Keys_to_list fs) fs)) ⊆ Keys (set (Macaulay_list fs))" unfolding set_Macaulay_red by (fact Keys_minus) also have "... ⊆ Keys (set fs)" by (fact Keys_Macaulay_list) finally show ?thesis . qed end (* ordered_term *) context gd_term begin lemma Macaulay_red_reducible: assumes "f ∈ phull (set fs)" and "F ⊆ set fs" and "lt_set F = lt_set (set fs)" shows "(lin_red (F ∪ set (Macaulay_red (Keys_to_list fs) fs)))⇧*⇧* f 0" proof - define A where "A = F ∪ set (Macaulay_red (Keys_to_list fs) fs)" have phull_A: "phull A ⊆ phull (set fs)" proof (rule phull.span_subset_spanI, simp add: A_def, rule) have "F ⊆ phull F" by (rule phull.span_superset) also from assms(2) have "... ⊆ phull (set fs)" by (rule phull.span_mono) finally show "F ⊆ phull (set fs)" . next have "set (Macaulay_red (Keys_to_list fs) fs) ⊆ set (Macaulay_list fs)" by (auto simp add: set_Macaulay_red) also have "... ⊆ phull (set (Macaulay_list fs))" by (rule phull.span_superset) also have "... = phull (set fs)" by (rule phull_Macaulay_list) finally show "set (Macaulay_red (Keys_to_list fs) fs) ⊆ phull (set fs)" . qed have lt_A: "p ∈ phull (set fs) ⟹ p ≠ 0 ⟹ (⋀g. g ∈ A ⟹ g ≠ 0 ⟹ lt g = lt p ⟹ thesis) ⟹ thesis" for p thesis proof - assume "p ∈ phull (set fs)" and "p ≠ 0" then obtain g where g_in: "g ∈ set (Macaulay_list fs)" and "g ≠ 0" and "lt p = lt g" by (rule Macaulay_list_lt) assume *: "⋀g. g ∈ A ⟹ g ≠ 0 ⟹ lt g = lt p ⟹ thesis" show ?thesis proof (cases "g ∈ set (Macaulay_red (Keys_to_list fs) fs)") case True hence "g ∈ A" by (simp add: A_def) from this ‹g ≠ 0› ‹lt p = lt g›[symmetric] show ?thesis by (rule *) next case False with g_in have "lt g ∈ lt_set (set fs)" by (simp add: set_Macaulay_red) also have "... = lt_set F" by (simp only: assms(3)) finally obtain g' where "g' ∈ F" and "g' ≠ 0" and "lt g' = lt g" by (rule lt_setE) from this(1) have "g' ∈ A" by (simp add: A_def) moreover note ‹g' ≠ 0› moreover have "lt g' = lt p" by (simp only: ‹lt p = lt g› ‹lt g' = lt g›) ultimately show ?thesis by (rule *) qed qed from assms(2) finite_set have "finite F" by (rule finite_subset) from this finite_set have fin_A: "finite A" unfolding A_def by (rule finite_UnI) from ex_dgrad obtain d::"'a ⇒ nat" where dg: "dickson_grading d" .. from fin_A have "finite (insert f A)" .. then obtain m where "insert f A ⊆ dgrad_p_set d m" by (rule dgrad_p_set_exhaust) hence A_sub: "A ⊆ dgrad_p_set d m" and "f ∈ dgrad_p_set d m" by simp_all from dg have "wfP (dickson_less_p d m)" by (rule wf_dickson_less_p) from this assms(1) ‹f ∈ dgrad_p_set d m› show "(lin_red A)⇧*⇧* f 0" proof (induct f) fix p assume IH: "⋀q. dickson_less_p d m q p ⟹ q ∈ phull (set fs) ⟹ q ∈ dgrad_p_set d m ⟹ (lin_red A)⇧*⇧* q 0" and "p ∈ phull (set fs)" and "p ∈ dgrad_p_set d m" show "(lin_red A)⇧*⇧* p 0" proof (cases "p = 0") case True thus ?thesis by simp next case False with ‹p ∈ phull (set fs)› obtain g where "g ∈ A" and "g ≠ 0" and "lt g = lt p" by (rule lt_A) define q where "q = p - monom_mult (lc p / lc g) 0 g" from ‹g ∈ A› have lr: "lin_red A p q" proof (rule lin_redI) show "red_single p q g 0" by (simp add: red_single_def ‹lt g = lt p› lc_def[symmetric] q_def ‹g ≠ 0› lc_not_0[OF False] term_simps) qed moreover have "(lin_red A)⇧*⇧* q 0" proof - from lr have red: "red A p q" by (rule lin_red_imp_red) with dg A_sub ‹p ∈ dgrad_p_set d m› have "q ∈ dgrad_p_set d m" by (rule dgrad_p_set_closed_red) moreover from red have "q ≺⇩p p" by (rule red_ord) ultimately have "dickson_less_p d m q p" using ‹p ∈ dgrad_p_set d m› by (simp add: dickson_less_p_def) moreover from phull_A ‹p ∈ phull (set fs)› lr have "q ∈ phull (set fs)" by (rule phull_closed_lin_red) ultimately show ?thesis using ‹q ∈ dgrad_p_set d m› by (rule IH) qed ultimately show ?thesis by fastforce qed qed qed primrec pdata_pairs_to_list :: "('t, 'b::field, 'c) pdata_pair list ⇒ ('t ⇒⇩0 'b) list" where "pdata_pairs_to_list [] = []"| "pdata_pairs_to_list (p # ps) = (let f = fst (fst p); g = fst (snd p); lf = lp f; lg = lp g; l = lcs lf lg in (monom_mult (1 / lc f) (l - lf) f) # (monom_mult (1 / lc g) (l - lg) g) # (pdata_pairs_to_list ps) )" lemma in_pdata_pairs_to_listI1: assumes "(f, g) ∈ set ps" shows "monom_mult (1 / lc (fst f)) ((lcs (lp (fst f)) (lp (fst g))) - (lp (fst f))) (fst f) ∈ set (pdata_pairs_to_list ps)" (is "?m ∈ _") using assms proof (induct ps) case Nil thus ?case by simp next case (Cons p ps) from Cons(2) have "p = (f, g) ∨ (f, g) ∈ set ps" by auto thus ?case proof assume "p = (f, g)" show ?thesis by (simp add: ‹p = (f, g)› Let_def) next assume "(f, g) ∈ set ps" hence "?m ∈ set (pdata_pairs_to_list ps)" by (rule Cons(1)) thus ?thesis by (simp add: Let_def) qed qed lemma in_pdata_pairs_to_listI2: assumes "(f, g) ∈ set ps" shows "monom_mult (1 / lc (fst g)) ((lcs (lp (fst f)) (lp (fst g))) - (lp (fst g))) (fst g) ∈ set (pdata_pairs_to_list ps)" (is "?m ∈ _") using assms proof (induct ps) case Nil thus ?case by simp next case (Cons p ps) from Cons(2) have "p = (f, g) ∨ (f, g) ∈ set ps" by auto thus ?case proof assume "p = (f, g)" show ?thesis by (simp add: ‹p = (f, g)› Let_def) next assume "(f, g) ∈ set ps" hence "?m ∈ set (pdata_pairs_to_list ps)" by (rule Cons(1)) thus ?thesis by (simp add: Let_def) qed qed lemma in_pdata_pairs_to_listE: assumes "h ∈ set (pdata_pairs_to_list ps)" obtains f g where "(f, g) ∈ set ps ∨ (g, f) ∈ set ps" and "h = monom_mult (1 / lc (fst f)) ((lcs (lp (fst f)) (lp (fst g))) - (lp (fst f))) (fst f)" using assms proof (induct ps arbitrary: thesis) case Nil from Nil(2) show ?case by simp next case (Cons p ps) let ?f = "fst (fst p)" let ?g = "fst (snd p)" let ?lf = "lp ?f" let ?lg = "lp ?g" let ?l = "lcs ?lf ?lg" from Cons(3) have "h = monom_mult (1 / lc ?f) (?l - ?lf) ?f ∨ h = monom_mult (1 / lc ?g) (?l - ?lg) ?g ∨ h ∈ set (pdata_pairs_to_list ps)" by (simp add: Let_def) thus ?case proof (elim disjE) assume h: "h = monom_mult (1 / lc ?f) (?l - ?lf) ?f" have "(fst p, snd p) ∈ set (p # ps)" by simp hence "(fst p, snd p) ∈ set (p # ps) ∨ (snd p, fst p) ∈ set (p # ps)" .. from this h show ?thesis by (rule Cons(2)) next assume h: "h = monom_mult (1 / lc ?g) (?l - ?lg) ?g" have "(fst p, snd p) ∈ set (p # ps)" by simp hence "(snd p, fst p) ∈ set (p # ps) ∨ (fst p, snd p) ∈ set (p # ps)" .. moreover from h have "h = monom_mult (1 / lc ?g) ((lcs ?lg ?lf) - ?lg) ?g" by (simp only: lcs_comm) ultimately show ?thesis by (rule Cons(2)) next assume h_in: "h ∈ set (pdata_pairs_to_list ps)" obtain f g where "(f, g) ∈ set ps ∨ (g, f) ∈ set ps" and h: "h = monom_mult (1 / lc (fst f)) ((lcs (lp (fst f)) (lp (fst g))) - (lp (fst f))) (fst f)" by (rule Cons(1), assumption, intro h_in) from this(1) have "(f, g) ∈ set (p # ps) ∨ (g, f) ∈ set (p # ps)" by auto from this h show ?thesis by (rule Cons(2)) qed qed definition f4_red_aux :: "('t, 'b::field, 'c) pdata list ⇒ ('t, 'b, 'c) pdata_pair list ⇒ ('t ⇒⇩0 'b) list" where "f4_red_aux bs ps = (let aux = sym_preproc (map fst bs) (pdata_pairs_to_list ps) in Macaulay_red (fst aux) (snd aux))" text ‹@{const f4_red_aux} only takes two arguments, since it does not distinguish between those elements of the current basis that are known to be a Gr\"obner basis (called ‹gs› in @{theory Groebner_Bases.Algorithm_Schema}) and the remaining ones.› lemma f4_red_aux_not_zero: "0 ∉ set (f4_red_aux bs ps)" by (simp add: f4_red_aux_def Let_def fst_sym_preproc set_Macaulay_red set_Macaulay_list) lemma f4_red_aux_irredudible: assumes "h ∈ set (f4_red_aux bs ps)" and "b ∈ set bs" and "fst b ≠ 0" shows "¬ lt (fst b) adds⇩t lt h" proof from assms(1) f4_red_aux_not_zero have "h ≠ 0" by metis hence "lt h ∈ keys h" by (rule lt_in_keys) also from assms(1) have "... ⊆ Keys (set (f4_red_aux bs ps))" by (rule keys_subset_Keys) also have "... ⊆ Keys (set (snd (sym_preproc (map fst bs) (pdata_pairs_to_list ps))))" (is "_ ⊆ Keys (set ?s)") by (simp only: f4_red_aux_def Let_def fst_sym_preproc Keys_Macaulay_red) finally have "lt h ∈ Keys (set ?s)" . moreover from assms(2) have "fst b ∈ set (map fst bs)" by auto moreover assume a: "lt (fst b) adds⇩t lt h" ultimately have "monom_mult 1 (lp h - lp (fst b)) (fst b) ∈ set ?s" (is "?m ∈ _") by (rule snd_sym_preproc_complete) from assms(3) have "?m ≠ 0" by (simp add: monom_mult_eq_zero_iff) with ‹?m ∈ set ?s› have "lt ?m ∈ lt_set (set ?s)" by (rule lt_setI) moreover from assms(3) a have "lt ?m = lt h" by (simp add: lt_monom_mult, metis add_diff_cancel_right' adds_termE pp_of_term_splus) ultimately have "lt h ∈ lt_set (set ?s)" by simp moreover from assms(1) have "lt h ∉ lt_set (set ?s)" by (simp add: f4_red_aux_def Let_def fst_sym_preproc set_Macaulay_red) ultimately show False by simp qed lemma f4_red_aux_dgrad_p_set_le: assumes "dickson_grading d" shows "dgrad_p_set_le d (set (f4_red_aux bs ps)) (args_to_set ([], bs, ps))" unfolding dgrad_p_set_le_def dgrad_set_le_def proof fix s assume "s ∈ pp_of_term ` Keys (set (f4_red_aux bs ps))" also have "... ⊆ pp_of_term ` Keys (set (snd (sym_preproc (map fst bs) (pdata_pairs_to_list ps))))" (is "_ ⊆ pp_of_term ` Keys (set ?s)") by (rule image_mono, simp only: f4_red_aux_def Let_def fst_sym_preproc Keys_Macaulay_red) finally have "s ∈ pp_of_term ` Keys (set ?s)" . with snd_sym_preproc_dgrad_set_le[OF assms] obtain t where "t ∈ pp_of_term ` Keys (set (map fst bs) ∪ set (pdata_pairs_to_list ps))" and "d s ≤ d t" by (rule dgrad_set_leE) from this(1) have "t ∈ pp_of_term ` Keys (fst ` set bs) ∨ t ∈ pp_of_term ` Keys (set (pdata_pairs_to_list ps))" by (simp add: Keys_Un image_Un) thus "∃t ∈ pp_of_term ` Keys (args_to_set ([], bs, ps)). d s ≤ d t" proof assume "t ∈ pp_of_term ` Keys (fst ` set bs)" also have "... ⊆ pp_of_term ` Keys (args_to_set ([], bs, ps))" by (rule image_mono, rule Keys_mono, auto simp add: args_to_set_alt) finally have "t ∈ pp_of_term ` Keys (args_to_set ([], bs, ps))" . with ‹d s ≤ d t› show ?thesis .. next assume "t ∈ pp_of_term ` Keys (set (pdata_pairs_to_list ps))" then obtain p where "p ∈ set (pdata_pairs_to_list ps)" and "t ∈ pp_of_term ` keys p" by (auto elim: in_KeysE) from this(1) obtain f g where disj: "(f, g) ∈ set ps ∨ (g, f) ∈ set ps" and p: "p = monom_mult (1 / lc (fst f)) ((lcs (lp (fst f)) (lp (fst g))) - (lp (fst f))) (fst f)" by (rule in_pdata_pairs_to_listE) from disj have "fst f ∈ args_to_set ([], bs, ps) ∧ fst g ∈ args_to_set ([], bs, ps)" proof assume "(f, g) ∈ set ps" hence "f ∈ fst ` set ps" and "g ∈ snd ` set ps" by force+ hence "fst f ∈ fst ` fst ` set ps" and "fst g ∈ fst ` snd ` set ps" by simp_all thus ?thesis by (simp add: args_to_set_def image_Un) next assume "(g, f) ∈ set ps" hence "f ∈ snd ` set ps" and "g ∈ fst ` set ps" by force+ hence "fst f ∈ fst ` snd ` set ps" and "fst g ∈ fst ` fst ` set ps" by simp_all thus ?thesis by (simp add: args_to_set_def image_Un) qed hence "fst f ∈ args_to_set ([], bs, ps)" and "fst g ∈ args_to_set ([], bs, ps)" by simp_all hence keys_f: "keys (fst f) ⊆ Keys (args_to_set ([], bs, ps))" and keys_g: "keys (fst g) ⊆ Keys (args_to_set ([], bs, ps))" by (auto intro!: keys_subset_Keys) let ?lf = "lp (fst f)" let ?lg = "lp (fst g)" define l where "l = lcs ?lf ?lg" have "pp_of_term ` keys p ⊆ pp_of_term ` ((⊕) (lcs ?lf ?lg - ?lf) ` keys (fst f))" unfolding p using keys_monom_mult_subset by (rule image_mono) with ‹t ∈ pp_of_term ` keys p› have "t ∈ pp_of_term ` ((⊕) (l - ?lf) ` keys (fst f))" unfolding l_def .. then obtain t' where "t' ∈ pp_of_term ` keys (fst f)" and t: "t = (l - ?lf) + t'" using pp_of_term_splus by fastforce from this(1) have "fst f ≠ 0" by auto show ?thesis proof (cases "fst g = 0") case True hence "?lg = 0" by (simp add: lt_def min_term_def term_simps) hence "l = ?lf" by (simp add: l_def lcs_zero lcs_comm) hence "t = t'" by (simp add: t) with ‹d s ≤ d t› have "d s ≤ d t'" by simp moreover from ‹t' ∈ pp_of_term ` keys (fst f)› keys_f have "t' ∈ pp_of_term ` Keys (args_to_set ([], bs, ps))" by blast ultimately show ?thesis .. next case False have "d t = d (l - ?lf) ∨ d t = d t'" by (auto simp add: t dickson_gradingD1[OF assms]) thus ?thesis proof assume "d t = d (l - ?lf)" also from assms have "... ≤ ord_class.max (d ?lf) (d ?lg)" unfolding l_def by (rule dickson_grading_lcs_minus) finally have "d s ≤ d ?lf ∨ d s ≤ d ?lg" using ‹d s ≤ d t› by auto thus ?thesis proof assume "d s ≤ d ?lf" moreover have "lt (fst f) ∈ Keys (args_to_set ([], bs, ps))" by (rule, rule lt_in_keys, fact+) ultimately show ?thesis by blast next assume "d s ≤ d ?lg" moreover have "lt (fst g) ∈ Keys (args_to_set ([], bs, ps))" by (rule, rule lt_in_keys, fact+) ultimately show ?thesis by blast qed next assume "d t = d t'" with ‹d s ≤ d t› have "d s ≤ d t'" by simp moreover from ‹t' ∈ pp_of_term ` keys (fst f)› keys_f have "t' ∈ pp_of_term ` Keys (args_to_set ([], bs, ps))" by blast ultimately show ?thesis .. qed qed qed qed lemma components_f4_red_aux_subset: "component_of_term ` Keys (set (f4_red_aux bs ps)) ⊆ component_of_term ` Keys (args_to_set ([], bs, ps))" proof fix k assume "k ∈ component_of_term ` Keys (set (f4_red_aux bs ps))" also have "... ⊆ component_of_term ` Keys (set (snd (sym_preproc (map fst bs) (pdata_pairs_to_list ps))))" by (rule image_mono, simp only: f4_red_aux_def Let_def fst_sym_preproc Keys_Macaulay_red) also have "... ⊆ component_of_term ` Keys (set (map fst bs) ∪ set (pdata_pairs_to_list ps))" by (fact components_snd_sym_preproc_subset) finally have "k ∈ component_of_term ` Keys (fst ` set bs) ∪ component_of_term ` Keys (set (pdata_pairs_to_list ps))" by (simp add: image_Un Keys_Un) thus "k ∈ component_of_term ` Keys (args_to_set ([], bs, ps))" proof assume "k ∈ component_of_term ` Keys (fst ` set bs)" also have "... ⊆ component_of_term ` Keys (args_to_set ([], bs, ps))" by (rule image_mono, rule Keys_mono, auto simp add: args_to_set_alt) finally show "k ∈ component_of_term ` Keys (args_to_set ([], bs, ps))" . next assume "k ∈ component_of_term ` Keys (set (pdata_pairs_to_list ps))" then obtain p where "p ∈ set (pdata_pairs_to_list ps)" and "k ∈ component_of_term ` keys p" by (auto elim: in_KeysE) from this(1) obtain f g where disj: "(f, g) ∈ set ps ∨ (g, f) ∈ set ps" and p: "p = monom_mult (1 / lc (fst f)) ((lcs (lp (fst f)) (lp (fst g))) - (lp (fst f))) (fst f)" by (rule in_pdata_pairs_to_listE) from disj have "fst f ∈ args_to_set ([], bs, ps)" by (simp add: args_to_set_alt, metis fst_conv image_eqI snd_conv) hence "fst f ∈ args_to_set ([], bs, ps)" by simp hence keys_f: "keys (fst f) ⊆ Keys (args_to_set ([], bs, ps))" by (auto intro!: keys_subset_Keys) let ?lf = "lp (fst f)" let ?lg = "lp (fst g)" define l where "l = lcs ?lf ?lg" have "component_of_term ` keys p ⊆ component_of_term ` ((⊕) (lcs ?lf ?lg - ?lf) ` keys (fst f))" unfolding p using keys_monom_mult_subset by (rule image_mono) with ‹k ∈ component_of_term ` keys p› have "k ∈ component_of_term ` ((⊕) (l - ?lf) ` keys (fst f))" unfolding l_def .. hence "k ∈ component_of_term ` keys (fst f)" using component_of_term_splus by fastforce with keys_f show "k ∈ component_of_term ` Keys (args_to_set ([], bs, ps))" by blast qed qed lemma pmdl_f4_red_aux: "set (f4_red_aux bs ps) ⊆ pmdl (args_to_set ([], bs, ps))" proof - have "set (f4_red_aux bs ps) ⊆ set (Macaulay_list (snd (sym_preproc (map fst bs) (pdata_pairs_to_list ps))))" by (auto simp add: f4_red_aux_def Let_def fst_sym_preproc set_Macaulay_red) also have "... ⊆ pmdl (set (Macaulay_list (snd (sym_preproc (map fst bs) (pdata_pairs_to_list ps)))))" by (fact pmdl.span_superset) also have "... = pmdl (set (snd (sym_preproc (map fst bs) (pdata_pairs_to_list ps))))" by (fact pmdl_Macaulay_list) also have "... ⊆ pmdl (set (map fst bs) ∪ set (snd (sym_preproc (map fst bs) (pdata_pairs_to_list ps))))" by (rule pmdl.span_mono, blast) also have "... = pmdl (set (map fst bs) ∪ set (pdata_pairs_to_list ps))" by (fact snd_sym_preproc_pmdl) also have "... ⊆ pmdl (args_to_set ([], bs, ps))" proof (rule pmdl.span_subset_spanI, simp only: Un_subset_iff, rule conjI) have "set (map fst bs) ⊆ args_to_set ([], bs, ps)" by (auto simp add: args_to_set_def) also have "... ⊆ pmdl (args_to_set ([], bs, ps))" by (rule pmdl.span_superset) finally show "set (map fst bs) ⊆ pmdl (args_to_set ([], bs, ps))" . next show "set (pdata_pairs_to_list ps) ⊆ pmdl (args_to_set ([], bs, ps))" proof fix p assume "p ∈ set (pdata_pairs_to_list ps)" then obtain f g where "(f, g) ∈ set ps ∨ (g, f) ∈ set ps" and p: "p = monom_mult (1 / lc (fst f)) ((lcs (lp (fst f)) (lp (fst g))) - (lp (fst f))) (fst f)" by (rule in_pdata_pairs_to_listE) from this(1) have "f ∈ fst ` set ps ∪ snd ` set ps" by force hence "fst f ∈ args_to_set ([], bs, ps)" by (auto simp add: args_to_set_alt) hence "fst f ∈ pmdl (args_to_set ([], bs, ps))" by (rule pmdl.span_base) thus "p ∈ pmdl (args_to_set ([], bs, ps))" unfolding p by (rule pmdl_closed_monom_mult) qed qed finally show ?thesis . qed lemma f4_red_aux_phull_reducible: assumes "set ps ⊆ set bs × set bs" and "f ∈ phull (set (pdata_pairs_to_list ps))" shows "(red (fst ` set bs ∪ set (f4_red_aux bs ps)))⇧*⇧* f 0" proof - define fs where "fs = snd (sym_preproc (map fst bs) (pdata_pairs_to_list ps))" have "set (pdata_pairs_to_list ps) ⊆ set fs" unfolding fs_def by (fact snd_sym_preproc_superset) hence "phull (set (pdata_pairs_to_list ps)) ⊆ phull (set fs)" by (rule phull.span_mono) with assms(2) have f_in: "f ∈ phull (set fs)" .. have eq: "(set fs) ∪ set (f4_red_aux bs ps) = (set fs) ∪ set (Macaulay_red (Keys_to_list fs) fs)" by (simp add: f4_red_aux_def fs_def Let_def fst_sym_preproc) have "(lin_red ((set fs) ∪ set (f4_red_aux bs ps)))⇧*⇧* f 0" by (simp only: eq, rule Macaulay_red_reducible, fact f_in, fact subset_refl, fact refl) thus ?thesis proof induct case base show ?case .. next case (step y z) from step(2) have "red (fst ` set bs ∪ set (f4_red_aux bs ps)) y z" unfolding lin_red_Un proof assume "lin_red (set fs) y z" then obtain a where "a ∈ set fs" and r: "red_single y z a 0" by (rule lin_redE) from this(1) obtain b c t where "b ∈ fst ` set bs" and a: "a = monom_mult c t b" unfolding fs_def proof (rule in_snd_sym_preprocE) assume *: "⋀b c t. b ∈ fst ` set bs ⟹ a = monom_mult c t b ⟹ thesis" assume "a ∈ set (pdata_pairs_to_list ps)" then obtain f g where "(f, g) ∈ set ps ∨ (g, f) ∈ set ps" and a: "a = monom_mult (1 / lc (fst f)) ((lcs (lp (fst f)) (lp (fst g))) - (lp (fst f))) (fst f)" by (rule in_pdata_pairs_to_listE) from this(1) have "f ∈ fst ` set ps ∪ snd ` set ps" by force with assms(1) have "f ∈ set bs" by fastforce hence "fst f ∈ fst ` set bs" by simp from this a show ?thesis by (rule *) next fix g s assume *: "⋀b c t. b ∈ fst ` set bs ⟹ a = monom_mult c t b ⟹ thesis" assume "g ∈ set (map fst bs)" hence "g ∈ fst ` set bs" by simp moreover assume "a = monom_mult 1 s g" ultimately show ?thesis by (rule *) qed from r have "c ≠ 0" and "b ≠ 0" by (simp_all add: a red_single_def monom_mult_eq_zero_iff) from r have "red_single y z b t" by (simp add: a red_single_def monom_mult_eq_zero_iff lt_monom_mult[OF ‹c ≠ 0› ‹b ≠ 0›] monom_mult_assoc term_simps) with ‹b ∈ fst ` set bs› have "red (fst ` set bs) y z" by (rule red_setI) thus ?thesis by (rule red_unionI1) next assume "lin_red (set (f4_red_aux bs ps)) y z" hence "red (set (f4_red_aux bs ps)) y z" by (rule lin_red_imp_red) thus ?thesis by (rule red_unionI2) qed with step(3) show ?case .. qed qed corollary f4_red_aux_spoly_reducible: assumes "set ps ⊆ set bs × set bs" and "(p, q) ∈ set ps" shows "(red (fst ` set bs ∪ set (f4_red_aux bs ps)))⇧*⇧* (spoly (fst p) (fst q)) 0" using assms(1) proof (rule f4_red_aux_phull_reducible) let ?lt = "lp (fst p)" let ?lq = "lp (fst q)" let ?l = "lcs ?lt ?lq" let ?p = "monom_mult (1 / lc (fst p)) (?l - ?lt) (fst p)" let ?q = "monom_mult (1 / lc (fst q)) (?l - ?lq) (fst q)" from assms(2) have "?p ∈ set (pdata_pairs_to_list ps)" and "?q ∈ set (pdata_pairs_to_list ps)" by (rule in_pdata_pairs_to_listI1, rule in_pdata_pairs_to_listI2) hence "?p ∈ phull (set (pdata_pairs_to_list ps))" and "?q ∈ phull (set (pdata_pairs_to_list ps))" by (auto intro: phull.span_base) hence "?p - ?q ∈ phull (set (pdata_pairs_to_list ps))" by (rule phull.span_diff) thus "spoly (fst p) (fst q) ∈ phull (set (pdata_pairs_to_list ps))" by (simp add: spoly_def Let_def phull.span_zero lc_def split: if_split) qed definition f4_red :: "('t, 'b::field, 'c::default, 'd) complT" where "f4_red gs bs ps sps data = (map (λh. (h, default)) (f4_red_aux (gs @ bs) sps), snd data)" lemma fst_set_fst_f4_red: "fst ` set (fst (f4_red gs bs ps sps data)) = set (f4_red_aux (gs @ bs) sps)" by (simp add: f4_red_def, force) lemma rcp_spec_f4_red: "rcp_spec f4_red" proof (rule rcp_specI) fix gs bs::"('t, 'b, 'c) pdata list" and ps sps and data::"nat × 'd" show "0 ∉ fst ` set (fst (f4_red gs bs ps sps data))" by (simp add: fst_set_fst_f4_red f4_red_aux_not_zero) next fix gs bs::"('t, 'b, 'c) pdata list" and ps sps h b and data::"nat × 'd" assume "h ∈ set (fst (f4_red gs bs ps sps data))" and "b ∈ set gs ∪ set bs" from this(1) have "fst h ∈ fst ` set (fst (f4_red gs bs ps sps data))" by simp hence "fst h ∈ set (f4_red_aux (gs @ bs) sps)" by (simp only: fst_set_fst_f4_red) moreover from ‹b ∈ set gs ∪ set bs› have "b ∈ set (gs @ bs)" by simp moreover assume "fst b ≠ 0" ultimately show "¬ lt (fst b) adds⇩t lt (fst h)" by (rule f4_red_aux_irredudible) next fix gs bs::"('t, 'b, 'c) pdata list" and ps sps and d::"'a ⇒ nat" and data::"nat × 'd" assume "dickson_grading d" hence "dgrad_p_set_le d (set (f4_red_aux (gs @ bs) sps)) (args_to_set ([], gs @ bs, sps))" by (fact f4_red_aux_dgrad_p_set_le) also have "... = args_to_set (gs, bs, sps)" by (simp add: args_to_set_alt image_Un) finally show "dgrad_p_set_le d (fst ` set (fst (f4_red gs bs ps sps data))) (args_to_set (gs, bs, sps))" by (simp only: fst_set_fst_f4_red) next fix gs bs::"('t, 'b, 'c) pdata list" and ps sps and data::"nat × 'd" have "component_of_term ` Keys (set (f4_red_aux (gs @ bs) sps)) ⊆ component_of_term ` Keys (args_to_set ([], gs @ bs, sps))" by (fact components_f4_red_aux_subset) also have "... = component_of_term ` Keys (args_to_set (gs, bs, sps))" by (simp add: args_to_set_alt image_Un) finally show "component_of_term ` Keys (fst ` set (fst (f4_red gs bs ps sps data))) ⊆ component_of_term ` Keys (args_to_set (gs, bs, sps))" by (simp only: fst_set_fst_f4_red) next fix gs bs::"('t, 'b, 'c) pdata list" and ps sps and data::"nat × 'd" have "set (f4_red_aux (gs @ bs) sps) ⊆ pmdl (args_to_set ([], gs @ bs, sps))" by (fact pmdl_f4_red_aux) also have "... = pmdl (args_to_set (gs, bs, sps))" by (simp add: args_to_set_alt image_Un) finally have "fst ` set (fst (f4_red gs bs ps sps data)) ⊆ pmdl (args_to_set (gs, bs, sps))" by (simp only: fst_set_fst_f4_red) moreover { fix p q :: "('t, 'b, 'c) pdata" assume "set sps ⊆ set bs × (set gs ∪ set bs)" hence "set sps ⊆ set (gs @ bs) × set (gs @ bs)" by fastforce moreover assume "(p, q) ∈ set sps" ultimately have "(red (fst ` set (gs @ bs) ∪ set (f4_red_aux (gs @ bs) sps)))⇧*⇧* (spoly (fst p) (fst q)) 0" by (rule f4_red_aux_spoly_reducible) } ultimately show "fst ` set (fst (f4_red gs bs ps sps data)) ⊆ pmdl (args_to_set (gs, bs, sps)) ∧ (∀(p, q)∈set sps. set sps ⊆ set bs × (set gs ∪ set bs) ⟶ (red (fst ` (set gs ∪ set bs) ∪ fst ` set (fst (f4_red gs bs ps sps data))))⇧*⇧* (spoly (fst p) (fst q)) 0)" by (auto simp add: image_Un fst_set_fst_f4_red) qed lemmas compl_struct_f4_red = compl_struct_rcp[OF rcp_spec_f4_red] lemmas compl_pmdl_f4_red = compl_pmdl_rcp[OF rcp_spec_f4_red] lemmas compl_conn_f4_red = compl_conn_rcp[OF rcp_spec_f4_red] subsection ‹Pair Selection› primrec f4_sel_aux :: "'a ⇒ ('t, 'b::zero, 'c) pdata_pair list ⇒ ('t, 'b, 'c) pdata_pair list" where "f4_sel_aux _ [] = []"| "f4_sel_aux t (p # ps) = (if (lcs (lp (fst (fst p))) (lp (fst (snd p)))) = t then p # (f4_sel_aux t ps) else [] )" lemma f4_sel_aux_subset: "set (f4_sel_aux t ps) ⊆ set ps" by (induct ps, auto) primrec f4_sel :: "('t, 'b::zero, 'c, 'd) selT" where "f4_sel gs bs [] data = []"| "f4_sel gs bs (p # ps) data = p # (f4_sel_aux (lcs (lp (fst (fst p))) (lp (fst (snd p)))) ps)" lemma sel_spec_f4_sel: "sel_spec f4_sel" proof (rule sel_specI) fix gs bs :: "('t, 'b, 'c) pdata list" and ps::"('t, 'b, 'c) pdata_pair list" and data::"nat × 'd" assume "ps ≠ []" then obtain p ps' where ps: "ps = p # ps'" by (meson list.exhaust) show "f4_sel gs bs ps data ≠ [] ∧ set (f4_sel gs bs ps data) ⊆ set ps" proof show "f4_sel gs bs ps data ≠ []" by (simp add: ps) next from f4_sel_aux_subset show "set (f4_sel gs bs ps data) ⊆ set ps" by (auto simp add: ps) qed qed subsection ‹The F4 Algorithm› text ‹The F4 algorithm is just @{const gb_schema_direct} with parameters instantiated by suitable functions.› lemma struct_spec_f4: "struct_spec f4_sel add_pairs_canon add_basis_canon f4_red" using sel_spec_f4_sel ap_spec_add_pairs_canon ab_spec_add_basis_sorted compl_struct_f4_red by (rule struct_specI) definition f4_aux :: "('t, 'b, 'c) pdata list ⇒ nat × nat × 'd ⇒ ('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata_pair list ⇒ ('t, 'b::field, 'c::default) pdata list" where "f4_aux = gb_schema_aux f4_sel add_pairs_canon add_basis_canon f4_red" lemmas f4_aux_simps [code] = gb_schema_aux_simps[OF struct_spec_f4, folded f4_aux_def] definition f4 :: "('t, 'b, 'c) pdata' list ⇒ 'd ⇒ ('t, 'b::field, 'c::default) pdata' list" where "f4 = gb_schema_direct f4_sel add_pairs_canon add_basis_canon f4_red" lemmas f4_simps [code] = gb_schema_direct_def[of f4_sel add_pairs_canon add_basis_canon f4_red, folded f4_def f4_aux_def] lemmas f4_isGB = gb_schema_direct_isGB[OF struct_spec_f4 compl_conn_f4_red, folded f4_def] lemmas f4_pmdl = gb_schema_direct_pmdl[OF struct_spec_f4 compl_pmdl_f4_red, folded f4_def] subsubsection ‹Special Case: ‹punit›› lemma (in gd_term) struct_spec_f4_punit: "punit.struct_spec punit.f4_sel add_pairs_punit_canon punit.add_basis_canon punit.f4_red" using punit.sel_spec_f4_sel ap_spec_add_pairs_punit_canon ab_spec_add_basis_sorted punit.compl_struct_f4_red by (rule punit.struct_specI) definition f4_aux_punit :: "('a, 'b, 'c) pdata list ⇒ nat × nat × 'd ⇒ ('a, 'b, 'c) pdata list ⇒ ('a, 'b, 'c) pdata_pair list ⇒ ('a, 'b::field, 'c::default) pdata list" where "f4_aux_punit = punit.gb_schema_aux punit.f4_sel add_pairs_punit_canon punit.add_basis_canon punit.f4_red" lemmas f4_aux_punit_simps [code] = punit.gb_schema_aux_simps[OF struct_spec_f4_punit, folded f4_aux_punit_def] definition f4_punit :: "('a, 'b, 'c) pdata' list ⇒ 'd ⇒ ('a, 'b::field, 'c::default) pdata' list" where "f4_punit = punit.gb_schema_direct punit.f4_sel add_pairs_punit_canon punit.add_basis_canon punit.f4_red" lemmas f4_punit_simps [code] = punit.gb_schema_direct_def[of "punit.f4_sel" add_pairs_punit_canon "punit.add_basis_canon" "punit.f4_red", folded f4_punit_def f4_aux_punit_def] lemmas f4_punit_isGB = punit.gb_schema_direct_isGB[OF struct_spec_f4_punit punit.compl_conn_f4_red, folded f4_punit_def] lemmas f4_punit_pmdl = punit.gb_schema_direct_pmdl[OF struct_spec_f4_punit punit.compl_pmdl_f4_red, folded f4_punit_def] end (* gd_term *) end (* theory *)
Theory F4_Examples
(* Author: Alexander Maletzky *) section ‹Sample Computations with the F4 Algorithm› theory F4_Examples imports F4 Algorithm_Schema_Impl Jordan_Normal_Form.Gauss_Jordan_IArray_Impl Code_Target_Rat begin text ‹We only consider scalar polynomials here, but vector-polynomials could be handled, too.› subsection ‹Preparations› primrec remdups_wrt_rev :: "('a ⇒ 'b) ⇒ 'a list ⇒ 'b list ⇒ 'a list" where "remdups_wrt_rev f [] vs = []" | "remdups_wrt_rev f (x # xs) vs = (let fx = f x in if List.member vs fx then remdups_wrt_rev f xs vs else x # (remdups_wrt_rev f xs (fx # vs)))" lemma remdups_wrt_rev_notin: "v ∈ set vs ⟹ v ∉ f ` set (remdups_wrt_rev f xs vs)" proof (induct xs arbitrary: vs) case Nil show ?case by simp next case (Cons x xs) from Cons(2) have 1: "v ∉ f ` set (remdups_wrt_rev f xs vs)" by (rule Cons(1)) from Cons(2) have "v ∈ set (f x # vs)" by simp hence 2: "v ∉ f ` set (remdups_wrt_rev f xs (f x # vs))" by (rule Cons(1)) from Cons(2) show ?case by (auto simp: Let_def 1 2 List.member_def) qed lemma distinct_remdups_wrt_rev: "distinct (map f (remdups_wrt_rev f xs vs))" proof (induct xs arbitrary: vs) case Nil show ?case by simp next case (Cons x xs) show ?case by (simp add: Let_def Cons(1) remdups_wrt_rev_notin) qed lemma map_of_remdups_wrt_rev': "map_of (remdups_wrt_rev fst xs vs) k = map_of (filter (λx. fst x ∉ set vs) xs) k" proof (induct xs arbitrary: vs) case Nil show ?case by simp next case (Cons x xs) show ?case proof (simp add: Let_def List.member_def Cons, intro impI) assume "k ≠ fst x" have "map_of (filter (λy. fst y ≠ fst x ∧ fst y ∉ set vs) xs) = map_of (filter (λy. fst y ≠ fst x) (filter (λy. fst y ∉ set vs) xs))" by (simp only: filter_filter conj_commute) also have "... = map_of (filter (λy. fst y ∉ set vs) xs) |` {y. y ≠ fst x}" by (rule map_of_filter) finally show "map_of (filter (λy. fst y ≠ fst x ∧ fst y ∉ set vs) xs) k = map_of (filter (λy. fst y ∉ set vs) xs) k" by (simp add: restrict_map_def ‹k ≠ fst x›) qed qed corollary map_of_remdups_wrt_rev: "map_of (remdups_wrt_rev fst xs []) = map_of xs" by (rule ext, simp add: map_of_remdups_wrt_rev') lemma (in term_powerprod) compute_list_to_poly [code]: "list_to_poly ts cs = distr⇩0 DRLEX (remdups_wrt_rev fst (zip ts cs) [])" by (rule poly_mapping_eqI, simp add: lookup_list_to_poly list_to_fun_def distr⇩0_def oalist_of_list_ntm_def oa_ntm.lookup_oalist_of_list distinct_remdups_wrt_rev lookup_dflt_def map_of_remdups_wrt_rev) lemma (in ordered_term) compute_Macaulay_list [code]: "Macaulay_list ps = (let ts = Keys_to_list ps in filter (λp. p ≠ 0) (mat_to_polys ts (row_echelon (polys_to_mat ts ps))) )" by (simp add: Macaulay_list_def Macaulay_mat_def Let_def) declare conversep_iff [code] derive (eq) ceq poly_mapping derive (no) ccompare poly_mapping derive (dlist) set_impl poly_mapping derive (no) cenum poly_mapping derive (eq) ceq rat derive (no) ccompare rat derive (dlist) set_impl rat derive (no) cenum rat global_interpretation punit': gd_powerprod "ord_pp_punit cmp_term" "ord_pp_strict_punit cmp_term" rewrites "punit.adds_term = (adds)" and "punit.pp_of_term = (λx. x)" and "punit.component_of_term = (λ_. ())" and "punit.monom_mult = monom_mult_punit" and "punit.mult_scalar = mult_scalar_punit" and "punit'.punit.min_term = min_term_punit" and "punit'.punit.lt = lt_punit cmp_term" and "punit'.punit.lc = lc_punit cmp_term" and "punit'.punit.tail = tail_punit cmp_term" and "punit'.punit.ord_p = ord_p_punit cmp_term" and "punit'.punit.ord_strict_p = ord_strict_p_punit cmp_term" and "punit'.punit.keys_to_list = keys_to_list_punit cmp_term" for cmp_term :: "('a::nat, 'b::{nat,add_wellorder}) pp nat_term_order" defines max_punit = punit'.ordered_powerprod_lin.max and max_list_punit = punit'.ordered_powerprod_lin.max_list and find_adds_punit = punit'.punit.find_adds and trd_aux_punit = punit'.punit.trd_aux and trd_punit = punit'.punit.trd and spoly_punit = punit'.punit.spoly and count_const_lt_components_punit = punit'.punit.count_const_lt_components and count_rem_components_punit = punit'.punit.count_rem_components and const_lt_component_punit = punit'.punit.const_lt_component and full_gb_punit = punit'.punit.full_gb and add_pairs_single_sorted_punit = punit'.punit.add_pairs_single_sorted and add_pairs_punit = punit'.punit.add_pairs and canon_pair_order_aux_punit = punit'.punit.canon_pair_order_aux and canon_basis_order_punit = punit'.punit.canon_basis_order and new_pairs_sorted_punit = punit'.punit.new_pairs_sorted and product_crit_punit = punit'.punit.product_crit and chain_ncrit_punit = punit'.punit.chain_ncrit and chain_ocrit_punit = punit'.punit.chain_ocrit and apply_icrit_punit = punit'.punit.apply_icrit and apply_ncrit_punit = punit'.punit.apply_ncrit and apply_ocrit_punit = punit'.punit.apply_ocrit and Keys_to_list_punit = punit'.punit.Keys_to_list and sym_preproc_addnew_punit = punit'.punit.sym_preproc_addnew and sym_preproc_aux_punit = punit'.punit.sym_preproc_aux and sym_preproc_punit = punit'.punit.sym_preproc and Macaulay_mat_punit = punit'.punit.Macaulay_mat and Macaulay_list_punit = punit'.punit.Macaulay_list and pdata_pairs_to_list_punit = punit'.punit.pdata_pairs_to_list and Macaulay_red_punit = punit'.punit.Macaulay_red and f4_sel_aux_punit = punit'.punit.f4_sel_aux and f4_sel_punit = punit'.punit.f4_sel and f4_red_aux_punit = punit'.punit.f4_red_aux and f4_red_punit = punit'.punit.f4_red and f4_aux_punit = punit'.punit.f4_aux_punit and f4_punit = punit'.punit.f4_punit subgoal by (fact gd_powerprod_ord_pp_punit) subgoal by (fact punit_adds_term) subgoal by (simp add: id_def) subgoal by (fact punit_component_of_term) subgoal by (simp only: monom_mult_punit_def) subgoal by (simp only: mult_scalar_punit_def) subgoal using min_term_punit_def by fastforce subgoal by (simp only: lt_punit_def ord_pp_punit_alt) subgoal by (simp only: lc_punit_def ord_pp_punit_alt) subgoal by (simp only: tail_punit_def ord_pp_punit_alt) subgoal by (simp only: ord_p_punit_def ord_pp_strict_punit_alt) subgoal by (simp only: ord_strict_p_punit_def ord_pp_strict_punit_alt) subgoal by (simp only: keys_to_list_punit_def ord_pp_punit_alt) done subsection ‹Computations› experiment begin interpretation trivariate⇩0_rat . lemma "lt_punit DRLEX (X⇧2 * Z ^ 3 + 3 * X⇧2 * Y) = sparse⇩0 [(0, 2), (2, 3)]" by eval lemma "lc_punit DRLEX (X⇧2 * Z ^ 3 + 3 * X⇧2 * Y) = 1" by eval lemma "tail_punit DRLEX (X⇧2 * Z ^ 3 + 3 * X⇧2 * Y) = 3 * X⇧2 * Y" by eval lemma "ord_strict_p_punit DRLEX (X⇧2 * Z ^ 4 - 2 * Y ^ 3 * Z⇧2) (X⇧2 * Z ^ 7 + 2 * Y ^ 3 * Z⇧2)" by eval lemma "f4_punit DRLEX [ (X⇧2 * Z ^ 4 - 2 * Y ^ 3 * Z⇧2, ()), (Y⇧2 * Z + 2 * Z ^ 3, ()) ] () = [ (X⇧2 * Y⇧2 * Z⇧2 + 4 * Y ^ 3 * Z⇧2, ()), (X⇧2 * Z ^ 4 - 2 * Y ^ 3 * Z⇧2, ()), (Y⇧2 * Z + 2 * Z ^ 3, ()), (X⇧2 * Y ^ 4 * Z + 4 * Y ^ 5 * Z, ()) ]" by eval lemma "f4_punit DRLEX [ (X⇧2 + Y⇧2 + Z⇧2 - 1, ()), (X * Y - Z - 1, ()), (Y⇧2 + X, ()), (Z⇧2 + X, ()) ] () = [ (1, ()) ]" by eval end value [code] "length (f4_punit DRLEX (map (λp. (p, ())) ((cyclic DRLEX 4)::(_ ⇒⇩0 rat) list)) ())" value [code] "length (f4_punit DRLEX (map (λp. (p, ())) ((katsura DRLEX 2)::(_ ⇒⇩0 rat) list)) ())" end (* theory *)
Theory Syzygy
(* Author: Alexander Maletzky *) section ‹Syzygies of Multivariate Polynomials› theory Syzygy imports Groebner_Bases More_MPoly_Type_Class begin text ‹In this theory we first introduce the general concept of @{emph ‹syzygies›} in modules, and then provide a method for computing Gr\"obner bases of syzygy modules of lists of multivariate vector-polynomials. Since syzygies in this context are themselves represented by vector-polynomials, this method can be applied repeatedly to compute bases of syzygy modules of syzygies, and so on.› instance nat :: comm_powerprod .. subsection ‹Syzygy Modules Generated by Sets› context module begin definition rep :: "('b ⇒⇩0 'a) ⇒ 'b" where "rep r = (∑v∈keys r. lookup r v *s v)" definition represents :: "'b set ⇒ ('b ⇒⇩0 'a) ⇒ 'b ⇒ bool" where "represents B r x ⟷ (keys r ⊆ B ∧ local.rep r = x)" definition syzygy_module :: "'b set ⇒ ('b ⇒⇩0 'a) set" where "syzygy_module B = {s. local.represents B s 0}" end hide_const (open) real_vector.rep real_vector.represents real_vector.syzygy_module context module begin lemma rep_monomial [simp]: "rep (monomial c x) = c *s x" proof - have sub: "keys (monomial c x) ⊆ {x}" by simp have "rep (monomial c x) = (∑v∈{x}. lookup (monomial c x) v *s v)" unfolding rep_def by (rule sum.mono_neutral_left, simp, fact sub, simp) also have "... = c *s x" by simp finally show ?thesis . qed lemma rep_zero [simp]: "rep 0 = 0" by (simp add: rep_def) lemma rep_uminus [simp]: "rep (- r) = - rep r" by (simp add: keys_uminus sum_negf rep_def) lemma rep_plus: "rep (r + s) = rep r + rep s" proof - from finite_keys finite_keys have fin: "finite (keys r ∪ keys s)" by (rule finite_UnI) from fin have eq1: "(∑v∈keys r ∪ keys s. lookup r v *s v) = (∑v∈keys r. lookup r v *s v)" proof (rule sum.mono_neutral_right) show "∀v∈keys r ∪ keys s - keys r. lookup r v *s v = 0" by (simp add: in_keys_iff) qed simp from fin have eq2: "(∑v∈keys r ∪ keys s. lookup s v *s v) = (∑v∈keys s. lookup s v *s v)" proof (rule sum.mono_neutral_right) show "∀v∈keys r ∪ keys s - keys s. lookup s v *s v = 0" by (simp add: in_keys_iff) qed simp have "rep (r + s) = (∑v∈keys (r + s). lookup (r + s) v *s v)" by (simp only: rep_def) also have "... = (∑v∈keys r ∪ keys s. lookup (r + s) v *s v)" proof (rule sum.mono_neutral_left) show "∀i∈keys r ∪ keys s - keys (r + s). lookup (r + s) i *s i = 0" by (simp add: in_keys_iff) qed (auto simp: Poly_Mapping.keys_add) also have "... = (∑v∈keys r ∪ keys s. lookup r v *s v) + (∑v∈keys r ∪ keys s. lookup s v *s v)" by (simp add: lookup_add scale_left_distrib sum.distrib) also have "... = rep r + rep s" by (simp only: eq1 eq2 rep_def) finally show ?thesis . qed lemma rep_minus: "rep (r - s) = rep r - rep s" proof - from finite_keys finite_keys have fin: "finite (keys r ∪ keys s)" by (rule finite_UnI) from fin have eq1: "(∑v∈keys r ∪ keys s. lookup r v *s v) = (∑v∈keys r. lookup r v *s v)" proof (rule sum.mono_neutral_right) show "∀v∈keys r ∪ keys s - keys r. lookup r v *s v = 0" by (simp add: in_keys_iff) qed simp from fin have eq2: "(∑v∈keys r ∪ keys s. lookup s v *s v) = (∑v∈keys s. lookup s v *s v)" proof (rule sum.mono_neutral_right) show "∀v∈keys r ∪ keys s - keys s. lookup s v *s v = 0" by (simp add: in_keys_iff) qed simp have "rep (r - s) = (∑v∈keys (r - s). lookup (r - s) v *s v)" by (simp only: rep_def) also from fin keys_minus have "... = (∑v∈keys r ∪ keys s. lookup (r - s) v *s v)" proof (rule sum.mono_neutral_left) show "∀i∈keys r ∪ keys s - keys (r - s). lookup (r - s) i *s i = 0" by (simp add: in_keys_iff) qed also have "... = (∑v∈keys r ∪ keys s. lookup r v *s v) - (∑v∈keys r ∪ keys s. lookup s v *s v)" by (simp add: lookup_minus scale_left_diff_distrib sum_subtractf) also have "... = rep r - rep s" by (simp only: eq1 eq2 rep_def) finally show ?thesis . qed lemma rep_smult: "rep (monomial c 0 * r) = c *s rep r" proof - have l: "lookup (monomial c 0 * r) v = c * (lookup r v)" for v unfolding mult_map_scale_conv_mult[symmetric] by (rule map_lookup, simp) have sub: "keys (monomial c 0 * r) ⊆ keys r" by (metis l lookup_not_eq_zero_eq_in_keys mult_zero_right subsetI) have "rep (monomial c 0 * r) = (∑v∈keys (monomial c 0 * r). lookup (monomial c 0 * r) v *s v)" by (simp only: rep_def) also from finite_keys sub have "... = (∑v∈keys r. lookup (monomial c 0 * r) v *s v)" proof (rule sum.mono_neutral_left) show "∀v∈keys r - keys (monomial c 0 * r). lookup (monomial c 0 * r) v *s v = 0" by (simp add: in_keys_iff) qed also have "... = c *s (∑v∈keys r. lookup r v *s v)" by (simp add: l scale_sum_right) also have "... = c *s rep r" by (simp add: rep_def) finally show ?thesis . qed lemma rep_in_span: "rep r ∈ span (keys r)" unfolding rep_def by (fact sum_in_spanI) lemma spanE_rep: assumes "x ∈ span B" obtains r where "keys r ⊆ B" and "x = rep r" proof - from assms obtain A q where "finite A" and "A ⊆ B" and x: "x = (∑a∈A. q a *s a)" by (rule spanE) define r where "r = Abs_poly_mapping (λk. q k when k ∈ A)" have 1: "lookup r = (λk. q k when k ∈ A)" unfolding r_def by (rule Abs_poly_mapping_inverse, simp add: ‹finite A›) have 2: "keys r ⊆ A" by (auto simp: in_keys_iff 1) show ?thesis proof have "x = (∑a∈A. lookup r a *s a)" unfolding x by (rule sum.cong, simp_all add: 1) also from ‹finite A› 2 have "... = (∑a∈keys r. lookup r a *s a)" proof (rule sum.mono_neutral_right) show "∀a∈A - keys r. lookup r a *s a = 0" by (simp add: in_keys_iff) qed finally show "x = rep r" by (simp only: rep_def) next from 2 ‹A ⊆ B› show "keys r ⊆ B" by (rule subset_trans) qed qed lemma representsI: assumes "keys r ⊆ B" and "rep r = x" shows "represents B r x" unfolding represents_def using assms by blast lemma representsD1: assumes "represents B r x" shows "keys r ⊆ B" using assms unfolding represents_def by blast lemma representsD2: assumes "represents B r x" shows "x = rep r" using assms unfolding represents_def by blast lemma represents_mono: assumes "represents B r x" and "B ⊆ A" shows "represents A r x" proof (rule representsI) from assms(1) have "keys r ⊆ B" by (rule representsD1) thus "keys r ⊆ A" using assms(2) by (rule subset_trans) next from assms(1) have "x = rep r" by (rule representsD2) thus "rep r = x" by (rule HOL.sym) qed lemma represents_self: "represents {x} (monomial 1 x) x" proof - have sub: "keys (monomial (1::'a) x) ⊆ {x}" by simp moreover have "rep (monomial (1::'a) x) = x" by simp ultimately show ?thesis by (rule representsI) qed lemma represents_zero: "represents B 0 0" by (rule representsI, simp_all) lemma represents_plus: assumes "represents A r x" and "represents B s y" shows "represents (A ∪ B) (r + s) (x + y)" proof - from assms(1) have r: "keys r ⊆ A" and x: "x = rep r" by (rule representsD1, rule representsD2) from assms(2) have s: "keys s ⊆ B" and y: "y = rep s" by (rule representsD1, rule representsD2) show ?thesis proof (rule representsI) from r s have "keys r ∪ keys s ⊆ A ∪ B" by blast thus "keys (r + s) ⊆ A ∪ B" by (meson Poly_Mapping.keys_add subset_trans) qed (simp add: rep_plus x y) qed lemma represents_uminus: assumes "represents B r x" shows "represents B (- r) (- x)" proof - from assms have r: "keys r ⊆ B" and x: "x = rep r" by (rule representsD1, rule representsD2) show ?thesis proof (rule representsI) from r show "keys (- r) ⊆ B" by (simp only: keys_uminus) qed (simp add: x) qed lemma represents_minus: assumes "represents A r x" and "represents B s y" shows "represents (A ∪ B) (r - s) (x - y)" proof - from assms(1) have r: "keys r ⊆ A" and x: "x = rep r" by (rule representsD1, rule representsD2) from assms(2) have s: "keys s ⊆ B" and y: "y = rep s" by (rule representsD1, rule representsD2) show ?thesis proof (rule representsI) from r s have "keys r ∪ keys s ⊆ A ∪ B" by blast with keys_minus show "keys (r - s) ⊆ A ∪ B" by (rule subset_trans) qed (simp only: rep_minus x y) qed lemma represents_scale: assumes "represents B r x" shows "represents B (monomial c 0 * r) (c *s x)" proof - from assms have r: "keys r ⊆ B" and x: "x = rep r" by (rule representsD1, rule representsD2) show ?thesis proof (rule representsI) have l: "lookup (monomial c 0 * r) v = c * (lookup r v)" for v unfolding mult_map_scale_conv_mult[symmetric] by (rule map_lookup, simp) have sub: "keys (monomial c 0 * r) ⊆ keys r" by (metis l lookup_not_eq_zero_eq_in_keys mult_zero_right subsetI) thus "keys (monomial c 0 * r) ⊆ B" using r by (rule subset_trans) qed (simp only: rep_smult x) qed lemma represents_in_span: assumes "represents B r x" shows "x ∈ span B" proof - from assms have r: "keys r ⊆ B" and x: "x = rep r" by (rule representsD1, rule representsD2) have "x ∈ span (keys r)" unfolding x by (fact rep_in_span) also from r have "... ⊆ span B" by (rule span_mono) finally show ?thesis . qed lemma syzygy_module_iff: "s ∈ syzygy_module B ⟷ represents B s 0" by (simp add: syzygy_module_def) lemma syzygy_moduleI: assumes "represents B s 0" shows "s ∈ syzygy_module B" unfolding syzygy_module_iff using assms . lemma syzygy_moduleD: assumes "s ∈ syzygy_module B" shows "represents B s 0" using assms unfolding syzygy_module_iff . lemma zero_in_syzygy_module: "0 ∈ syzygy_module B" using represents_zero by (rule syzygy_moduleI) lemma syzygy_module_closed_plus: assumes "s1 ∈ syzygy_module B" and "s2 ∈ syzygy_module B" shows "s1 + s2 ∈ syzygy_module B" proof - from assms(1) have "represents B s1 0" by (rule syzygy_moduleD) moreover from assms(2) have "represents B s2 0" by (rule syzygy_moduleD) ultimately have "represents (B ∪ B) (s1 + s2) (0 + 0)" by (rule represents_plus) hence "represents B (s1 + s2) 0" by simp thus ?thesis by (rule syzygy_moduleI) qed lemma syzygy_module_closed_minus: assumes "s1 ∈ syzygy_module B" and "s2 ∈ syzygy_module B" shows "s1 - s2 ∈ syzygy_module B" proof - from assms(1) have "represents B s1 0" by (rule syzygy_moduleD) moreover from assms(2) have "represents B s2 0" by (rule syzygy_moduleD) ultimately have "represents (B ∪ B) (s1 - s2) (0 - 0)" by (rule represents_minus) hence "represents B (s1 - s2) 0" by simp thus ?thesis by (rule syzygy_moduleI) qed lemma syzygy_module_closed_times_monomial: assumes "s ∈ syzygy_module B" shows "monomial c 0 * s ∈ syzygy_module B" proof - from assms(1) have "represents B s 0" by (rule syzygy_moduleD) hence "represents B (monomial c 0 * s) (c *s 0)" by (rule represents_scale) hence "represents B (monomial c 0 * s) 0" by simp thus ?thesis by (rule syzygy_moduleI) qed end (* module *) context term_powerprod begin lemma keys_rep_subset: assumes "u ∈ keys (pmdl.rep r)" obtains t v where "t ∈ Keys (Poly_Mapping.range r)" and "v ∈ Keys (keys r)" and "u = t ⊕ v" proof - note assms also have "keys (pmdl.rep r) ⊆ (⋃v∈keys r. keys (lookup r v ⊙ v))" by (simp add: pmdl.rep_def keys_sum_subset) finally obtain v0 where "v0 ∈ keys r" and "u ∈ keys (lookup r v0 ⊙ v0)" .. from this(2) obtain t v where "t ∈ keys (lookup r v0)" and "v ∈ keys v0" and "u = t ⊕ v" by (rule in_keys_mult_scalarE) show ?thesis proof from ‹v0 ∈ keys r› have "lookup r v0 ∈ Poly_Mapping.range r" by (rule in_keys_lookup_in_range) with ‹t ∈ keys (lookup r v0)› show "t ∈ Keys (Poly_Mapping.range r)" by (rule in_KeysI) next from ‹v ∈ keys v0› ‹v0 ∈ keys r› show "v ∈ Keys (keys r)" by (rule in_KeysI) qed fact qed lemma rep_mult_scalar: "pmdl.rep (punit.monom_mult c 0 r) = c ⊙ pmdl.rep r" unfolding punit.mult_scalar_monomial[symmetric] punit_mult_scalar by (fact pmdl.rep_smult) lemma represents_mult_scalar: assumes "pmdl.represents B r x" shows "pmdl.represents B (punit.monom_mult c 0 r) (c ⊙ x)" unfolding punit.mult_scalar_monomial[symmetric] punit_mult_scalar using assms by (rule pmdl.represents_scale) lemma syzygy_module_closed_map_scale: "s ∈ pmdl.syzygy_module B ⟹ c ⋅ s ∈ pmdl.syzygy_module B" unfolding map_scale_eq_times by (rule pmdl.syzygy_module_closed_times_monomial) lemma phull_syzygy_module: "phull (pmdl.syzygy_module B) = pmdl.syzygy_module B" unfolding phull.span_eq_iff apply (rule phull.subspaceI) subgoal by (fact pmdl.zero_in_syzygy_module) subgoal by (fact pmdl.syzygy_module_closed_plus) subgoal by (fact syzygy_module_closed_map_scale) done end (* term_powerprod *) subsection ‹Polynomial Mappings on List-Indices› definition pm_of_idx_pm :: "('a list) ⇒ (nat ⇒⇩0 'b) ⇒ 'a ⇒⇩0 'b::zero" where "pm_of_idx_pm xs f = Abs_poly_mapping (λx. lookup f (Min {i. i < length xs ∧ xs ! i = x}) when x ∈ set xs)" definition idx_pm_of_pm :: "('a list) ⇒ ('a ⇒⇩0 'b) ⇒ nat ⇒⇩0 'b::zero" where "idx_pm_of_pm xs f = Abs_poly_mapping (λi. lookup f (xs ! i) when i < length xs)" lemma lookup_pm_of_idx_pm: "lookup (pm_of_idx_pm xs f) = (λx. lookup f (Min {i. i < length xs ∧ xs ! i = x}) when x ∈ set xs)" unfolding pm_of_idx_pm_def by (rule Abs_poly_mapping_inverse, simp) lemma lookup_pm_of_idx_pm_distinct: assumes "distinct xs" and "i < length xs" shows "lookup (pm_of_idx_pm xs f) (xs ! i) = lookup f i" proof - from assms have "{j. j < length xs ∧ xs ! j = xs ! i} = {i}" using distinct_Ex1 nth_mem by fastforce moreover from assms(2) have "xs ! i ∈ set xs" by (rule nth_mem) ultimately show ?thesis by (simp add: lookup_pm_of_idx_pm) qed lemma keys_pm_of_idx_pm_subset: "keys (pm_of_idx_pm xs f) ⊆ set xs" proof fix t assume "t ∈ keys (pm_of_idx_pm xs f)" hence "lookup (pm_of_idx_pm xs f) t ≠ 0" by (simp add: in_keys_iff) thus "t ∈ set xs" by (simp add: lookup_pm_of_idx_pm) qed lemma range_pm_of_idx_pm_subset: "Poly_Mapping.range (pm_of_idx_pm xs f) ⊆ lookup f ` {0..<length xs} - {0}" proof fix c assume "c ∈ Poly_Mapping.range (pm_of_idx_pm xs f)" then obtain t where t: "t ∈ keys (pm_of_idx_pm xs f)" and c: "c = lookup (pm_of_idx_pm xs f) t" by (metis DiffE imageE insertCI not_in_keys_iff_lookup_eq_zero range.rep_eq) from t keys_pm_of_idx_pm_subset have "t ∈ set xs" .. hence c1: "c = lookup f (Min {i. i < length xs ∧ xs ! i = t})" by (simp add: lookup_pm_of_idx_pm c) show "c ∈ lookup f ` {0..<length xs} - {0}" proof (intro DiffI image_eqI) from ‹t ∈ set xs› obtain i where "i < length xs" and "t = xs ! i" by (metis in_set_conv_nth) have "finite {i. i < length xs ∧ xs ! i = t}" by simp moreover from ‹i < length xs› ‹t = xs ! i› have "{i. i < length xs ∧ xs ! i = t} ≠ {}" by auto ultimately have "Min {i. i < length xs ∧ xs ! i = t} ∈ {i. i < length xs ∧ xs ! i = t}" by (rule Min_in) thus "Min {i. i < length xs ∧ xs ! i = t} ∈ {0..<length xs}" by simp next from t show "c ∉ {0}" by (simp add: c in_keys_iff) qed (fact c1) qed corollary range_pm_of_idx_pm_subset': "Poly_Mapping.range (pm_of_idx_pm xs f) ⊆ Poly_Mapping.range f" using range_pm_of_idx_pm_subset proof (rule subset_trans) show "lookup f ` {0..<length xs} - {0} ⊆ Poly_Mapping.range f" by (transfer, auto) qed lemma pm_of_idx_pm_zero [simp]: "pm_of_idx_pm xs 0 = 0" by (rule poly_mapping_eqI, simp add: lookup_pm_of_idx_pm) lemma pm_of_idx_pm_plus: "pm_of_idx_pm xs (f + g) = pm_of_idx_pm xs f + pm_of_idx_pm xs g" by (rule poly_mapping_eqI, simp add: lookup_pm_of_idx_pm lookup_add when_def) lemma pm_of_idx_pm_uminus: "pm_of_idx_pm xs (- f) = - pm_of_idx_pm xs f" by (rule poly_mapping_eqI, simp add: lookup_pm_of_idx_pm when_def) lemma pm_of_idx_pm_minus: "pm_of_idx_pm xs (f - g) = pm_of_idx_pm xs f - pm_of_idx_pm xs g" by (rule poly_mapping_eqI, simp add: lookup_pm_of_idx_pm lookup_minus when_def) lemma pm_of_idx_pm_monom_mult: "pm_of_idx_pm xs (punit.monom_mult c 0 f) = punit.monom_mult c 0 (pm_of_idx_pm xs f)" by (rule poly_mapping_eqI, simp add: lookup_pm_of_idx_pm punit.lookup_monom_mult_zero when_def) lemma pm_of_idx_pm_monomial: assumes "distinct xs" shows "pm_of_idx_pm xs (monomial c i) = (monomial c (xs ! i) when i < length xs)" proof - from assms have *: "{i. i < length xs ∧ xs ! i = xs ! j} = {j}" if "j < length xs" for j using distinct_Ex1 nth_mem that by fastforce show ?thesis proof (cases "i < length xs") case True have "pm_of_idx_pm xs (monomial c i) = monomial c (xs ! i)" proof (rule poly_mapping_eqI) fix k show "lookup (pm_of_idx_pm xs (monomial c i)) k = lookup (monomial c (xs ! i)) k" proof (cases "xs ! i = k") case True with ‹i < length xs› have "k ∈ set xs" by auto thus ?thesis by (simp add: lookup_pm_of_idx_pm lookup_single *[OF ‹i < length xs›] True[symmetric]) next case False have "lookup (pm_of_idx_pm xs (monomial c i)) k = 0" proof (cases "k ∈ set xs") case True then obtain j where "j < length xs" and "k = xs ! j" by (metis in_set_conv_nth) with False have "i ≠ Min {i. i < length xs ∧ xs ! i = k}" by (auto simp: ‹k = xs ! j› *[OF ‹j < length xs›]) thus ?thesis by (simp add: lookup_pm_of_idx_pm True lookup_single) next case False thus ?thesis by (simp add: lookup_pm_of_idx_pm) qed with False show ?thesis by (simp add: lookup_single) qed qed with True show ?thesis by simp next case False have "pm_of_idx_pm xs (monomial c i) = 0" proof (rule poly_mapping_eqI, simp add: lookup_pm_of_idx_pm when_def, rule) fix k assume "k ∈ set xs" then obtain j where "j < length xs" and "k = xs ! j" by (metis in_set_conv_nth) with False have "i ≠ Min {i. i < length xs ∧ xs ! i = k}" by (auto simp: ‹k = xs ! j› *[OF ‹j < length xs›]) thus "lookup (monomial c i) (Min {i. i < length xs ∧ xs ! i = k}) = 0" by (simp add: lookup_single) qed with False show ?thesis by simp qed qed lemma pm_of_idx_pm_take: assumes "keys f ⊆ {0..<j}" shows "pm_of_idx_pm (take j xs) f = pm_of_idx_pm xs f" proof (rule poly_mapping_eqI) fix i let ?xs = "take j xs" let ?A = "{k. k < length xs ∧ xs ! k = i}" let ?B = "{k. k < length xs ∧ k < j ∧ xs ! k = i}" have A_fin: "finite ?A" and B_fin: "finite ?B" by fastforce+ have A_ne: "i ∈ set xs ⟹ ?A ≠ {}" by (simp add: in_set_conv_nth) have B_ne: "i ∈ set ?xs ⟹ ?B ≠ {}" by (auto simp add: in_set_conv_nth) define m1 where "m1 = Min ?A" define m2 where "m2 = Min ?B" have m1: "m1 ∈ ?A" if "i ∈ set xs" unfolding m1_def by (rule Min_in, fact A_fin, rule A_ne, fact that) have m2: "m2 ∈ ?B" if "i ∈ set ?xs" unfolding m2_def by (rule Min_in, fact B_fin, rule B_ne, fact that) show "lookup (pm_of_idx_pm (take j xs) f) i = lookup (pm_of_idx_pm xs f) i" proof (cases "i ∈ set ?xs") case True hence "i ∈ set xs" using set_take_subset .. hence "m1 ∈ ?A" by (rule m1) hence "m1 < length xs" and "xs ! m1 = i" by simp_all from True have "m2 ∈ ?B" by (rule m2) hence "m2 < length xs" and "m2 < j" and "xs ! m2 = i" by simp_all hence "m2 ∈ ?A" by simp with A_fin have "m1 ≤ m2" unfolding m1_def by (rule Min_le) with ‹m2 < j› have "m1 < j" by simp with ‹m1 < length xs› ‹xs ! m1 = i› have "m1 ∈ ?B" by simp with B_fin have "m2 ≤ m1" unfolding m2_def by (rule Min_le) with ‹m1 ≤ m2› have "m1 = m2" by (rule le_antisym) with True ‹i ∈ set xs› show ?thesis by (simp add: lookup_pm_of_idx_pm m1_def m2_def cong: conj_cong) next case False thus ?thesis proof (simp add: lookup_pm_of_idx_pm when_def m1_def[symmetric], intro impI) assume "i ∈ set xs" hence "m1 ∈ ?A" by (rule m1) hence "m1 < length xs" and "xs ! m1 = i" by simp_all have "m1 ∉ keys f" proof assume "m1 ∈ keys f" hence "m1 ∈ {0..<j}" using assms .. hence "m1 < j" by simp with ‹m1 < length xs› have "m1 < length ?xs" by simp hence "?xs ! m1 ∈ set ?xs" by (rule nth_mem) with ‹m1 < j› have "i ∈ set ?xs" by (simp add: ‹xs ! m1 = i›) with False show False .. qed thus "lookup f m1 = 0" by (simp add: in_keys_iff) qed qed qed lemma lookup_idx_pm_of_pm: "lookup (idx_pm_of_pm xs f) = (λi. lookup f (xs ! i) when i < length xs)" unfolding idx_pm_of_pm_def by (rule Abs_poly_mapping_inverse, simp) lemma keys_idx_pm_of_pm_subset: "keys (idx_pm_of_pm xs f) ⊆ {0..<length xs}" proof fix i assume "i ∈ keys (idx_pm_of_pm xs f)" hence "lookup (idx_pm_of_pm xs f) i ≠ 0" by (simp add: in_keys_iff) thus "i ∈ {0..<length xs}" by (simp add: lookup_idx_pm_of_pm) qed lemma idx_pm_of_pm_zero [simp]: "idx_pm_of_pm xs 0 = 0" by (rule poly_mapping_eqI, simp add: lookup_idx_pm_of_pm) lemma idx_pm_of_pm_plus: "idx_pm_of_pm xs (f + g) = idx_pm_of_pm xs f + idx_pm_of_pm xs g" by (rule poly_mapping_eqI, simp add: lookup_idx_pm_of_pm lookup_add when_def) lemma idx_pm_of_pm_minus: "idx_pm_of_pm xs (f - g) = idx_pm_of_pm xs f - idx_pm_of_pm xs g" by (rule poly_mapping_eqI, simp add: lookup_idx_pm_of_pm lookup_minus when_def) lemma pm_of_idx_pm_of_pm: assumes "keys f ⊆ set xs" shows "pm_of_idx_pm xs (idx_pm_of_pm xs f) = f" proof (rule poly_mapping_eqI, simp add: lookup_pm_of_idx_pm when_def, intro conjI impI) fix k assume "k ∈ set xs" define i where "i = Min {i. i < length xs ∧ xs ! i = k}" have "finite {i. i < length xs ∧ xs ! i = k}" by simp moreover from ‹k ∈ set xs› have "{i. i < length xs ∧ xs ! i = k} ≠ {}" by (simp add: in_set_conv_nth) ultimately have "i ∈ {i. i < length xs ∧ xs ! i = k}" unfolding i_def by (rule Min_in) hence "i < length xs" and "xs ! i = k" by simp_all thus "lookup (idx_pm_of_pm xs f) i = lookup f k" by (simp add: lookup_idx_pm_of_pm) next fix k assume "k ∉ set xs" with assms show "lookup f k = 0" by (auto simp: in_keys_iff) qed lemma idx_pm_of_pm_of_idx_pm: assumes "distinct xs" and "keys f ⊆ {0..<length xs}" shows "idx_pm_of_pm xs (pm_of_idx_pm xs f) = f" proof (rule poly_mapping_eqI) fix i show "lookup (idx_pm_of_pm xs (pm_of_idx_pm xs f)) i = lookup f i" proof (cases "i < length xs") case True with assms(1) show ?thesis by (simp add: lookup_idx_pm_of_pm lookup_pm_of_idx_pm_distinct) next case False hence "i ∉ {0..<length xs}" by simp with assms(2) have "i ∉ keys f" by blast with False show ?thesis by (simp add: in_keys_iff lookup_idx_pm_of_pm) qed qed subsection ‹POT Orders› context ordered_term begin definition is_pot_ord :: bool where "is_pot_ord ⟷ (∀u v. component_of_term u < component_of_term v ⟶ u ≺⇩t v)" lemma is_pot_ordI: assumes "⋀u v. component_of_term u < component_of_term v ⟹ u ≺⇩t v" shows "is_pot_ord" unfolding is_pot_ord_def using assms by blast lemma is_pot_ordD: assumes "is_pot_ord" and "component_of_term u < component_of_term v" shows "u ≺⇩t v" using assms unfolding is_pot_ord_def by blast lemma is_pot_ordD2: assumes "is_pot_ord" and "u ≼⇩t v" shows "component_of_term u ≤ component_of_term v" proof (rule ccontr) assume "¬ component_of_term u ≤ component_of_term v" hence "component_of_term v < component_of_term u" by simp with assms(1) have "v ≺⇩t u" by (rule is_pot_ordD) with assms(2) show False by simp qed lemma is_pot_ord: assumes "is_pot_ord" shows "u ≼⇩t v ⟷ (component_of_term u < component_of_term v ∨ (component_of_term u = component_of_term v ∧ pp_of_term u ≼ pp_of_term v))" (is "?l ⟷ ?r") proof assume ?l with assms have "component_of_term u ≤ component_of_term v" by (rule is_pot_ordD2) hence "component_of_term u < component_of_term v ∨ component_of_term u = component_of_term v" by (simp add: order_class.le_less) thus ?r proof assume "component_of_term u < component_of_term v" thus ?r .. next assume 1: "component_of_term u = component_of_term v" moreover have "pp_of_term u ≼ pp_of_term v" proof (rule ccontr) assume "¬ pp_of_term u ≼ pp_of_term v" hence 2: "pp_of_term v ≼ pp_of_term u" and 3: "pp_of_term u ≠ pp_of_term v" by simp_all from 1 have "component_of_term v ≤ component_of_term u" by simp with 2 have "v ≼⇩t u" by (rule ord_termI) with ‹?l› have "u = v" by simp with 3 show False by simp qed ultimately show ?r by simp qed next assume ?r thus ?l proof assume "component_of_term u < component_of_term v" with assms have "u ≺⇩t v" by (rule is_pot_ordD) thus ?l by simp next assume "component_of_term u = component_of_term v ∧ pp_of_term u ≼ pp_of_term v" hence "pp_of_term u ≼ pp_of_term v" and "component_of_term u ≤ component_of_term v" by simp_all thus ?l by (rule ord_termI) qed qed definition map_component :: "('k ⇒ 'k) ⇒ 't ⇒ 't" where "map_component f v = term_of_pair (pp_of_term v, f (component_of_term v))" lemma pair_of_map_component [term_simps]: "pair_of_term (map_component f v) = (pp_of_term v, f (component_of_term v))" by (simp add: map_component_def pair_term) lemma pp_of_map_component [term_simps]: "pp_of_term (map_component f v) = pp_of_term v" by (simp add: pp_of_term_def pair_of_map_component) lemma component_of_map_component [term_simps]: "component_of_term (map_component f v) = f (component_of_term v)" by (simp add: component_of_term_def pair_of_map_component) lemma map_component_term_of_pair [term_simps]: "map_component f (term_of_pair (t, k)) = term_of_pair (t, f k)" by (simp add: map_component_def term_simps) lemma map_component_comp: "map_component f (map_component g x) = map_component (λk. f (g k)) x" by (simp add: map_component_def term_simps) lemma map_component_id [term_simps]: "map_component (λk. k) x = x" by (simp add: map_component_def term_simps) lemma map_component_inj: assumes "inj f" and "map_component f u = map_component f v" shows "u = v" proof - from assms(2) have "term_of_pair (pp_of_term u, f (component_of_term u)) = term_of_pair (pp_of_term v, f (component_of_term v))" by (simp only: map_component_def) hence "(pp_of_term u, f (component_of_term u)) = (pp_of_term v, f (component_of_term v))" by (rule term_of_pair_injective) hence 1: "pp_of_term u = pp_of_term v" and "f (component_of_term u) = f (component_of_term v)" by simp_all from assms(1) this(2) have "component_of_term u = component_of_term v" by (rule injD) with 1 show ?thesis by (metis term_of_pair_pair) qed end (* ordered_term *) subsection ‹Gr\"obner Bases of Syzygy Modules› locale gd_inf_term = gd_term pair_of_term term_of_pair ord ord_strict ord_term ord_term_strict for pair_of_term::"'t ⇒ ('a::graded_dickson_powerprod × nat)" and term_of_pair::"('a × nat) ⇒ 't" and ord::"'a ⇒ 'a ⇒ bool" (infixl "≼" 50) and ord_strict (infixl "≺" 50) and ord_term::"'t ⇒ 't ⇒ bool" (infixl "≼⇩t" 50) and ord_term_strict::"'t ⇒ 't ⇒ bool" (infixl "≺⇩t" 50) begin text ‹In order to compute a Gr\"obner basis of the syzygy module of a list ‹bs› of polynomials, one first needs to ``lift'' ‹bs› to a new list ‹bs'› by adding further components, compute a Gr\"obner basis ‹gs› of ‹bs'›, and then filter out those elements of ‹gs› whose only non-zero components are those that were newly added to ‹bs›. Function ‹init_syzygy_list› takes care of constructing ‹bs'›, and function ‹filter_syzygy_basis› does the filtering. Function ‹proj_orig_basis›, finally, projects the Gr\"obner basis ‹gs› of ‹bs'› to a Gr\"obner basis of the original list ‹bs›.› definition lift_poly_syz :: "nat ⇒ ('t ⇒⇩0 'b) ⇒ nat ⇒ ('t ⇒⇩0 'b::semiring_1)" where "lift_poly_syz n b i = Abs_poly_mapping (λx. if pair_of_term x = (0, i) then 1 else if n ≤ component_of_term x then lookup b (map_component (λk. k - n) x) else 0)" definition proj_poly_syz :: "nat ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b::semiring_1)" where "proj_poly_syz n b = Poly_Mapping.map_key (λx. map_component (λk. k + n) x) b" definition cofactor_list_syz :: "nat ⇒ ('t ⇒⇩0 'b) ⇒ ('a ⇒⇩0 'b::semiring_1) list" where "cofactor_list_syz n b = map (λi. proj_poly i b) [0..<n]" definition init_syzygy_list :: "('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b::semiring_1) list" where "init_syzygy_list bs = map_idx (lift_poly_syz (length bs)) bs 0" definition proj_orig_basis :: "nat ⇒ ('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b::semiring_1) list" where "proj_orig_basis n bs = map (proj_poly_syz n) bs" definition filter_syzygy_basis :: "nat ⇒ ('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b::semiring_1) list" where "filter_syzygy_basis n bs = [b←bs. component_of_term ` keys b ⊆ {0..<n}]" definition syzygy_module_list :: "('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b::comm_ring_1) set" where "syzygy_module_list bs = atomize_poly ` idx_pm_of_pm bs ` pmdl.syzygy_module (set bs)" subsubsection ‹@{const lift_poly_syz}› lemma keys_lift_poly_syz_aux: "{x. (if pair_of_term x = (0, i) then 1 else if n ≤ component_of_term x then lookup b (map_component (λk. k - n) x) else 0) ≠ 0} ⊆ insert (term_of_pair (0, i)) (map_component (λk. k + n) ` keys b)" (is "?l ⊆ ?r") for b::"'t ⇒⇩0 'b::semiring_1" proof fix x::'t assume "x ∈ ?l" hence "(if pair_of_term x = (0, i) then 1 else if n ≤ component_of_term x then lookup b (map_component (λk. k - n) x) else 0) ≠ 0" by simp hence "pair_of_term x = (0, i) ∨ (n ≤ component_of_term x ∧ lookup b (map_component (λk. k - n) x) ≠ 0)" by (simp split: if_split_asm) thus "x ∈ ?r" proof assume "pair_of_term x = (0, i)" hence "(0, i) = pair_of_term x" by (rule sym) hence "x = term_of_pair (0, i)" by (simp add: term_pair) thus ?thesis by simp next assume "n ≤ component_of_term x ∧ lookup b (map_component (λk. k - n) x) ≠ 0" hence "n ≤ component_of_term x" and 2: "map_component (λk. k - n) x ∈ keys b" by (auto simp: in_keys_iff) from this(1) have 3: "map_component (λk. k - n + n) x = x" by (simp add: map_component_def term_simps) from 2 have "map_component (λk. k + n) (map_component (λk. k - n) x) ∈ map_component (λk. k + n) ` keys b" by (rule imageI) with 3 have "x ∈ map_component (λk. k + n) ` keys b" by (simp add: map_component_comp) thus ?thesis by simp qed qed lemma lookup_lift_poly_syz: "lookup (lift_poly_syz n b i) = (λx. if pair_of_term x = (0, i) then 1 else if n ≤ component_of_term x then lookup b (map_component (λk. k - n) x) else 0)" unfolding lift_poly_syz_def proof (rule Abs_poly_mapping_inverse) from finite_keys have "finite (map_component (λk. k + n) ` keys b)" .. hence "finite (insert (term_of_pair (0, i)) (map_component (λk. k + n) ` keys b))" by (rule finite.insertI) with keys_lift_poly_syz_aux have "finite {x. (if pair_of_term x = (0, i) then 1 else if n ≤ component_of_term x then lookup b (map_component (λk. k - n) x) else 0) ≠ 0}" by (rule finite_subset) thus "(λx. if pair_of_term x = (0, i) then 1 else if n ≤ component_of_term x then lookup b (map_component (λk. k - n) x) else 0) ∈ {f. finite {x. f x ≠ 0}}" by simp qed corollary lookup_lift_poly_syz_alt: "lookup (lift_poly_syz n b i) (term_of_pair (t, j)) = (if (t, j) = (0, i) then 1 else if n ≤ j then lookup b (term_of_pair (t, j - n)) else 0)" by (simp only: lookup_lift_poly_syz term_simps) lemma keys_lift_poly_syz: "keys (lift_poly_syz n b i) = insert (term_of_pair (0, i)) (map_component (λk. k + n) ` keys b)" proof have "keys (lift_poly_syz n b i) ⊆ {x. (if pair_of_term x = (0, i) then 1 else if n ≤ component_of_term x then lookup b (map_component (λk. k - n) x) else 0) ≠ 0}" (is "_ ⊆ ?A") proof fix x assume "x ∈ keys (lift_poly_syz n b i)" hence "lookup (lift_poly_syz n b i) x ≠ 0" by (simp add: in_keys_iff) thus "x ∈ ?A" by (simp add: lookup_lift_poly_syz) qed also note keys_lift_poly_syz_aux finally show "keys (lift_poly_syz n b i) ⊆ insert (term_of_pair (0, i)) (map_component (λk. k + n) ` keys b)" . next show "insert (term_of_pair (0, i)) (map_component (λk. k + n) ` keys b) ⊆ keys (lift_poly_syz n b i)" proof (simp, rule) have "lookup (lift_poly_syz n b i) (term_of_pair (0, i)) ≠ 0" by (simp add: lookup_lift_poly_syz_alt) thus "term_of_pair (0, i) ∈ keys (lift_poly_syz n b i)" by (simp add: in_keys_iff) next show "map_component (λk. k + n) ` keys b ⊆ keys (lift_poly_syz n b i)" proof (rule, elim imageE, simp) fix x assume "x ∈ keys b" hence "lookup (lift_poly_syz n b i) (map_component (λk. k + n) x) ≠ 0" by (simp add: in_keys_iff lookup_lift_poly_syz_alt map_component_def term_simps) thus "map_component (λk. k + n) x ∈ keys (lift_poly_syz n b i)" by (simp add: in_keys_iff) qed qed qed subsubsection ‹@{const proj_poly_syz}› lemma inj_map_component_plus: "inj (map_component (λk. k + n))" proof (rule injI) fix x y have "inj (λk::nat. k + n)" by (simp add: inj_def) moreover assume "map_component (λk. k + n) x = map_component (λk. k + n) y" ultimately show "x = y" by (rule map_component_inj) qed lemma lookup_proj_poly_syz: "lookup (proj_poly_syz n p) x = lookup p (map_component (λk. k + n) x)" by (simp add: proj_poly_syz_def map_key.rep_eq[OF inj_map_component_plus]) lemma lookup_proj_poly_syz_alt: "lookup (proj_poly_syz n p) (term_of_pair (t, i)) = lookup p (term_of_pair (t, i + n))" by (simp add: lookup_proj_poly_syz map_component_term_of_pair) lemma keys_proj_poly_syz: "keys (proj_poly_syz n p) = map_component (λk. k + n) -` keys p" by (simp add: proj_poly_syz_def keys_map_key[OF inj_map_component_plus]) lemma proj_poly_syz_zero [simp]: "proj_poly_syz n 0 = 0" by (rule poly_mapping_eqI, simp add: lookup_proj_poly_syz) lemma proj_poly_syz_plus: "proj_poly_syz n (p + q) = proj_poly_syz n p + proj_poly_syz n q" by (simp add: proj_poly_syz_def map_key_plus[OF inj_map_component_plus]) lemma proj_poly_syz_sum: "proj_poly_syz n (sum f A) = (∑a∈A. proj_poly_syz n (f a))" by (rule fun_sum_commute, simp_all add: proj_poly_syz_plus) lemma proj_poly_syz_sum_list: "proj_poly_syz n (sum_list xs) = sum_list (map (proj_poly_syz n) xs)" by (rule fun_sum_list_commute, simp_all add: proj_poly_syz_plus) lemma proj_poly_syz_monom_mult: "proj_poly_syz n (monom_mult c t p) = monom_mult c t (proj_poly_syz n p)" by (rule poly_mapping_eqI, simp add: lookup_proj_poly_syz lookup_monom_mult term_simps adds_pp_def sminus_def) lemma proj_poly_syz_mult_scalar: "proj_poly_syz n (mult_scalar q p) = mult_scalar q (proj_poly_syz n p)" by (rule fun_mult_scalar_commute, simp_all add: proj_poly_syz_plus proj_poly_syz_monom_mult) lemma proj_poly_syz_lift_poly_syz: assumes "i < n" shows "proj_poly_syz n (lift_poly_syz n p i) = p" proof (rule poly_mapping_eqI, simp add: lookup_proj_poly_syz lookup_lift_poly_syz term_simps map_component_comp, rule, elim conjE) fix x::'t assume "component_of_term x + n = i" hence "n ≤ i" by simp with assms show "lookup p x = 1" by simp qed lemma proj_poly_syz_eq_zero_iff: "proj_poly_syz n p = 0 ⟷ (component_of_term ` keys p ⊆ {0..<n})" unfolding keys_eq_empty[symmetric] keys_proj_poly_syz proof assume "map_component (λk. k + n) -` keys p = {}" (is "?A = {}") show "component_of_term ` keys p ⊆ {0..<n}" proof (rule, rule ccontr) fix i assume "i ∈ component_of_term ` keys p" then obtain x where x: "x ∈ keys p" and i: "i = component_of_term x" .. assume "i ∉ {0..<n}" hence "i - n + n = i" by simp hence 1: "map_component (λk. k - n + n) x = x" by (simp add: map_component_def i term_simps) have "map_component (λk. k - n) x ∈ ?A" by (rule vimageI2, simp add: map_component_comp x 1) thus False by (simp add: ‹?A = {}›) qed next assume a: "component_of_term ` keys p ⊆ {0..<n}" show "map_component (λk. k + n) -` keys p = {}" (is "?A = {}") proof (rule ccontr) assume "?A ≠ {}" then obtain x where "x ∈ ?A" by blast hence "map_component (λk. k + n) x ∈ keys p" by (rule vimageD) with a have "component_of_term (map_component (λk. k + n) x) ∈ {0..<n}" by blast thus False by (simp add: term_simps) qed qed lemma component_of_lt_ge: assumes "is_pot_ord" and "proj_poly_syz n p ≠ 0" shows "n ≤ component_of_term (lt p)" proof - from assms(2) have "¬ component_of_term ` keys p ⊆ {0..<n}" by (simp add: proj_poly_syz_eq_zero_iff) then obtain i where "i ∈ component_of_term ` keys p" and "i ∉ {0..<n}" by fastforce from this(1) obtain x where "x ∈ keys p" and i: "i = component_of_term x" .. from this(1) have "x ≼⇩t lt p" by (rule lt_max_keys) with assms(1) have "component_of_term x ≤ component_of_term (lt p)" by (rule is_pot_ordD2) with ‹i ∉ {0..<n}› show ?thesis by (simp add: i) qed lemma lt_proj_poly_syz: assumes "is_pot_ord" and "proj_poly_syz n p ≠ 0" shows "lt (proj_poly_syz n p) = map_component (λk. k - n) (lt p)" (is "_ = ?l") proof - from component_of_lt_ge[OF assms] have "component_of_term (lt p) - n + n = component_of_term (lt p)" by simp hence eq: "map_component (λk. k - n + n) (lt p) = lt p" by (simp add: map_component_def term_simps) show ?thesis proof (rule lt_eqI) have "lookup (proj_poly_syz n p) ?l = lc p" by (simp add: lc_def lookup_proj_poly_syz term_simps map_component_comp eq) also have "... ≠ 0" proof (rule lc_not_0, rule) assume "p = 0" hence "proj_poly_syz n p = 0" by simp with assms(2) show False .. qed finally show "lookup (proj_poly_syz n p) ?l ≠ 0" . next fix x assume "lookup (proj_poly_syz n p) x ≠ 0" hence "map_component (λk. k + n) x ∈ keys p" by (simp add: in_keys_iff lookup_proj_poly_syz) hence "map_component (λk. k + n) x ≼⇩t lt p" by (rule lt_max_keys) with assms(1) show "x ≼⇩t ?l" by (auto simp add: is_pot_ord term_simps) qed qed lemma proj_proj_poly_syz: "proj_poly k (proj_poly_syz n p) = proj_poly (k + n) p" by (rule poly_mapping_eqI, simp add: lookup_proj_poly lookup_proj_poly_syz_alt) lemma poly_mapping_eqI_proj_syz: assumes "proj_poly_syz n p = proj_poly_syz n q" and "⋀k. k < n ⟹ proj_poly k p = proj_poly k q" shows "p = q" proof (rule poly_mapping_eqI_proj) fix k show "proj_poly k p = proj_poly k q" proof (cases "k < n") case True thus ?thesis by (rule assms(2)) next case False have "proj_poly (k - n + n) p = proj_poly (k - n + n) q" by (simp only: proj_proj_poly_syz[symmetric] assms(1)) with False show ?thesis by simp qed qed subsubsection ‹@{const cofactor_list_syz}› lemma length_cofactor_list_syz [simp]: "length (cofactor_list_syz n p) = n" by (simp add: cofactor_list_syz_def) lemma cofactor_list_syz_nth: assumes "i < n" shows "(cofactor_list_syz n p) ! i = proj_poly i p" by (simp add: cofactor_list_syz_def map_idx_nth assms) lemma cofactor_list_syz_zero [simp]: "cofactor_list_syz n 0 = replicate n 0" by (rule nth_equalityI, simp_all add: cofactor_list_syz_nth proj_zero) lemma cofactor_list_syz_plus: "cofactor_list_syz n (p + q) = map2 (+) (cofactor_list_syz n p) (cofactor_list_syz n q)" by (rule nth_equalityI, simp_all add: cofactor_list_syz_nth proj_plus) subsubsection ‹@{const init_syzygy_list}› lemma length_init_syzygy_list [simp]: "length (init_syzygy_list bs) = length bs" by (simp add: init_syzygy_list_def) lemma init_syzygy_list_nth: assumes "i < length bs" shows "(init_syzygy_list bs) ! i = lift_poly_syz (length bs) (bs ! i) i" by (simp add: init_syzygy_list_def map_idx_nth[OF assms]) lemma Keys_init_syzygy_list: "Keys (set (init_syzygy_list bs)) = map_component (λk. k + length bs) ` Keys (set bs) ∪ (λi. term_of_pair (0, i)) ` {0..<length bs}" proof - have eq1: "(⋃b∈set bs. map_component (λk. k + length bs) ` keys b) = (⋃i∈{0..<length bs}. map_component (λk. k + length bs) ` keys (bs ! i))" by (fact UN_upt[symmetric]) have eq2: "(λi. term_of_pair (0, i)) ` {0..<length bs} = (⋃i∈{0..<length bs}. {term_of_pair (0, i)})" by auto show ?thesis by (simp add: init_syzygy_list_def set_map_idx Keys_def keys_lift_poly_syz image_UN eq1 eq2 UN_Un_distrib[symmetric]) qed lemma pp_of_Keys_init_syzygy_list_subset: "pp_of_term ` Keys (set (init_syzygy_list bs)) ⊆ insert 0 (pp_of_term ` Keys (set bs))" by (auto simp add: Keys_init_syzygy_list image_Un rev_image_eqI term_simps) lemma pp_of_Keys_init_syzygy_list_superset: "pp_of_term ` Keys (set bs) ⊆ pp_of_term ` Keys (set (init_syzygy_list bs))" by (simp add: Keys_init_syzygy_list image_Un term_simps image_image) lemma pp_of_Keys_init_syzygy_list: assumes "bs ≠ []" shows "pp_of_term ` Keys (set (init_syzygy_list bs)) = insert 0 (pp_of_term ` Keys (set bs))" proof show "insert 0 (pp_of_term ` Keys (set bs)) ⊆ pp_of_term ` Keys (set (init_syzygy_list bs))" proof (simp add: pp_of_Keys_init_syzygy_list_superset) from assms have "{0..<length bs} ≠ {}" by auto hence "Pair 0 ` {0..<length bs} ≠ {}" by blast then obtain x::'t where x: "x ∈ (λi. term_of_pair (0, i)) ` {0..<length bs}" by blast hence "pp_of_term ` (λi. term_of_pair (0, i)) ` {0..<length bs} = {pp_of_term x}" using image_subset_iff by (auto simp: term_simps) also from x have "... = {0}" using pp_of_term_of_pair by auto finally show "0 ∈ pp_of_term ` Keys (set (init_syzygy_list bs))" by (simp add: Keys_init_syzygy_list image_Un) qed qed (fact pp_of_Keys_init_syzygy_list_subset) lemma component_of_Keys_init_syzygy_list: "component_of_term ` Keys (set (init_syzygy_list bs)) = (+) (length bs) ` component_of_term ` Keys (set bs) ∪ {0..<length bs}" by (simp add: Keys_init_syzygy_list image_Un image_comp o_def ac_simps term_simps) lemma proj_lift_poly_syz: assumes "j < n" shows "proj_poly j (lift_poly_syz n p i) = (1 when j = i)" proof (simp add: when_def, intro conjI impI) assume "j = i" with assms have "¬ n ≤ i" by simp show "proj_poly i (lift_poly_syz n p i) = 1" by (rule poly_mapping_eqI, simp add: lookup_proj_poly lookup_lift_poly_syz_alt ‹¬ n ≤ i› lookup_one) next assume "j ≠ i" from assms have "¬ n ≤ j" by simp show "proj_poly j (lift_poly_syz n p i) = 0" by (rule poly_mapping_eqI, simp add: lookup_proj_poly lookup_lift_poly_syz_alt ‹¬ n ≤ j› ‹j ≠ i›) qed subsubsection ‹@{const proj_orig_basis}› lemma length_proj_orig_basis [simp]: "length (proj_orig_basis n bs) = length bs" by (simp add: proj_orig_basis_def) lemma proj_orig_basis_nth: assumes "i < length bs" shows "(proj_orig_basis n bs) ! i = proj_poly_syz n (bs ! i)" by (simp add: proj_orig_basis_def assms) lemma proj_orig_basis_init_syzygy_list [simp]: "proj_orig_basis (length bs) (init_syzygy_list bs) = bs" by (rule nth_equalityI, simp_all add: init_syzygy_list_nth proj_orig_basis_nth proj_poly_syz_lift_poly_syz) lemma set_proj_orig_basis: "set (proj_orig_basis n bs) = proj_poly_syz n ` set bs" by (simp add: proj_orig_basis_def) text ‹The following lemma could be generalized from @{const proj_poly_syz} to arbitrary module homomorphisms, i.\,e. functions respecting ‹0›, addition and scalar multiplication.› lemma pmdl_proj_orig_basis': "pmdl (set (proj_orig_basis n bs)) = proj_poly_syz n ` pmdl (set bs)" (is "?A = ?B") proof show "?A ⊆ ?B" proof fix p assume "p ∈ pmdl (set (proj_orig_basis n bs))" thus "p ∈ proj_poly_syz n ` pmdl (set bs)" proof (induct rule: pmdl_induct) case module_0 have "0 = proj_poly_syz n 0" by simp also from pmdl.span_zero have "... ∈ proj_poly_syz n ` pmdl (set bs)" by (rule imageI) finally show ?case . next case (module_plus p b c t) from module_plus(2) obtain q where "q ∈ pmdl (set bs)" and p: "p = proj_poly_syz n q" .. from module_plus(3) obtain a where "a ∈ set bs" and b: "b = proj_poly_syz n a" unfolding set_proj_orig_basis .. have "p + monom_mult c t b = proj_poly_syz n (q + monom_mult c t a)" by (simp add: p b proj_poly_syz_monom_mult proj_poly_syz_plus) also have "... ∈ proj_poly_syz n ` pmdl (set bs)" proof (rule imageI, rule pmdl.span_add) show "monom_mult c t a ∈ pmdl (set bs)" by (rule pmdl_closed_monom_mult, rule pmdl.span_base, fact) qed fact finally show ?case . qed qed next show "?B ⊆ ?A" proof fix p assume "p ∈ proj_poly_syz n ` pmdl (set bs)" then obtain q where "q ∈ pmdl (set bs)" and p: "p = proj_poly_syz n q" .. from this(1) show "p ∈ pmdl (set (proj_orig_basis n bs))" unfolding p proof (induct rule: pmdl_induct) case module_0 have "proj_poly_syz n 0 = 0" by simp also have "... ∈ pmdl (set (proj_orig_basis n bs))" by (fact pmdl.span_zero) finally show ?case . next case (module_plus q b c t) have "proj_poly_syz n (q + monom_mult c t b) = proj_poly_syz n q + monom_mult c t (proj_poly_syz n b)" by (simp add: proj_poly_syz_plus proj_poly_syz_monom_mult) also have "... ∈ pmdl (set (proj_orig_basis n bs))" proof (rule pmdl.span_add) show "monom_mult c t (proj_poly_syz n b) ∈ pmdl (set (proj_orig_basis n bs))" proof (rule pmdl_closed_monom_mult, rule pmdl.span_base) show "proj_poly_syz n b ∈ set (proj_orig_basis n bs)" by (simp add: set_proj_orig_basis, rule imageI, fact) qed qed fact finally show ?case . qed qed qed subsubsection ‹@{const filter_syzygy_basis}› lemma filter_syzygy_basis_alt: "filter_syzygy_basis n bs = [b←bs. proj_poly_syz n b = 0]" by (simp add: filter_syzygy_basis_def proj_poly_syz_eq_zero_iff) lemma set_filter_syzygy_basis: "set (filter_syzygy_basis n bs) = {b∈set bs. proj_poly_syz n b = 0}" by (simp add: filter_syzygy_basis_alt) subsubsection ‹@{const syzygy_module_list}› lemma syzygy_module_listI: assumes "s' ∈ pmdl.syzygy_module (set bs)" and "s = atomize_poly (idx_pm_of_pm bs s')" shows "s ∈ syzygy_module_list bs" unfolding assms(2) syzygy_module_list_def by (intro imageI, fact assms(1)) lemma syzygy_module_listE: assumes "s ∈ syzygy_module_list bs" obtains s' where "s' ∈ pmdl.syzygy_module (set bs)" and "s = atomize_poly (idx_pm_of_pm bs s')" using assms unfolding syzygy_module_list_def by (elim imageE, simp) lemma monom_mult_atomize: "monom_mult c t (atomize_poly p) = atomize_poly (MPoly_Type_Class.punit.monom_mult (monomial c t) 0 p)" by (rule poly_mapping_eqI_proj, simp add: proj_monom_mult proj_atomize_poly MPoly_Type_Class.punit.lookup_monom_mult times_monomial_left) lemma punit_monom_mult_monomial_idx_pm_of_pm: "MPoly_Type_Class.punit.monom_mult (monomial c t) (0::nat) (idx_pm_of_pm bs s) = idx_pm_of_pm bs (MPoly_Type_Class.punit.monom_mult (monomial c t) (0::'t ⇒⇩0 'b::ring_1) s)" by (rule poly_mapping_eqI, simp add: MPoly_Type_Class.punit.lookup_monom_mult lookup_idx_pm_of_pm when_def) lemma syzygy_module_list_closed_monom_mult: assumes "s ∈ syzygy_module_list bs" shows "monom_mult c t s ∈ syzygy_module_list bs" proof - from assms obtain s' where s': "s' ∈ pmdl.syzygy_module (set bs)" and s: "s = atomize_poly (idx_pm_of_pm bs s')" by (rule syzygy_module_listE) show ?thesis unfolding s proof (rule syzygy_module_listI) from s' show "(monomial c t) ⋅ s' ∈ pmdl.syzygy_module (set bs)" by (rule syzygy_module_closed_map_scale) next show "monom_mult c t (atomize_poly (idx_pm_of_pm bs s')) = atomize_poly (idx_pm_of_pm bs ((monomial c t) ⋅ s'))" by (simp add: monom_mult_atomize punit_monom_mult_monomial_idx_pm_of_pm MPoly_Type_Class.punit.map_scale_eq_monom_mult) qed qed lemma pmdl_syzygy_module_list [simp]: "pmdl (syzygy_module_list bs) = syzygy_module_list bs" proof (rule pmdl_idI) show "0 ∈ syzygy_module_list bs" by (rule syzygy_module_listI, fact pmdl.zero_in_syzygy_module, simp add: atomize_zero) next fix s1 s2 assume "s1 ∈ syzygy_module_list bs" then obtain s1' where s1': "s1' ∈ pmdl.syzygy_module (set bs)" and s1: "s1 = atomize_poly (idx_pm_of_pm bs s1')" by (rule syzygy_module_listE) assume "s2 ∈ syzygy_module_list bs" then obtain s2' where s2': "s2' ∈ pmdl.syzygy_module (set bs)" and s2: "s2 = atomize_poly (idx_pm_of_pm bs s2')" by (rule syzygy_module_listE) show "s1 + s2 ∈ syzygy_module_list bs" proof (rule syzygy_module_listI) from s1' s2' show "s1' + s2' ∈ pmdl.syzygy_module (set bs)" by (rule pmdl.syzygy_module_closed_plus) next show "s1 + s2 = atomize_poly (idx_pm_of_pm bs (s1' + s2'))" by (simp add: idx_pm_of_pm_plus atomize_plus s1 s2) qed qed (fact syzygy_module_list_closed_monom_mult) text ‹The following lemma also holds without the distinctness constraint on ‹bs›, but then the proof becomes more difficult.› lemma syzygy_module_listI': assumes "distinct bs" and "sum_list (map2 mult_scalar (cofactor_list_syz (length bs) s) bs) = 0" and "component_of_term ` keys s ⊆ {0..<length bs}" shows "s ∈ syzygy_module_list bs" proof (rule syzygy_module_listI) show "pm_of_idx_pm bs (vectorize_poly s) ∈ pmdl.syzygy_module (set bs)" proof (rule pmdl.syzygy_moduleI, rule pmdl.representsI) have "(∑v∈keys (pm_of_idx_pm bs (vectorize_poly s)). mult_scalar (lookup (pm_of_idx_pm bs (vectorize_poly s)) v) v) = (∑b∈set bs. mult_scalar (lookup (pm_of_idx_pm bs (vectorize_poly s)) b) b)" by (rule sum.mono_neutral_left, fact finite_set, fact keys_pm_of_idx_pm_subset, simp add: in_keys_iff) also have "... = sum_list (map (λb. mult_scalar (lookup (pm_of_idx_pm bs (vectorize_poly s)) b) b) bs)" by (simp only: sum_code distinct_remdups_id[OF assms(1)]) also have "... = sum_list (map2 mult_scalar (cofactor_list_syz (length bs) s) bs)" proof (rule arg_cong[of _ _ sum_list], rule nth_equalityI, simp_all) fix i assume "i < length bs" with assms(1) have "lookup (pm_of_idx_pm bs (vectorize_poly s)) (bs ! i) = cofactor_list_syz (length bs) s ! i" by (simp add: lookup_pm_of_idx_pm_distinct[OF assms(1)] cofactor_list_syz_nth lookup_vectorize_poly) thus "mult_scalar (lookup (pm_of_idx_pm bs (vectorize_poly s)) (bs ! i)) (bs ! i) = mult_scalar (cofactor_list_syz (length bs) s ! i) (bs ! i)" by (simp only:) qed also have "... = 0" by (fact assms(2)) finally show "pmdl.rep (pm_of_idx_pm bs (vectorize_poly s)) = 0" by (simp only: pmdl.rep_def) qed (fact keys_pm_of_idx_pm_subset) next from assms(3) have "keys (vectorize_poly s) ⊆ {0..<length bs}" by (simp add: keys_vectorize_poly) with assms(1) have "idx_pm_of_pm bs (pm_of_idx_pm bs (vectorize_poly s)) = vectorize_poly s" by (rule idx_pm_of_pm_of_idx_pm) thus "s = atomize_poly (idx_pm_of_pm bs (pm_of_idx_pm bs (vectorize_poly s)))" by (simp add: atomize_vectorize_poly) qed lemma component_of_syzygy_module_list: assumes "s ∈ syzygy_module_list bs" shows "component_of_term ` keys s ⊆ {0..<length bs}" proof - from assms obtain s' where s: "s = atomize_poly (idx_pm_of_pm bs s')" by (rule syzygy_module_listE) have "component_of_term ` keys s ⊆ (⋃x∈{0..<length bs}. {x})" by (simp only: s keys_atomize_poly image_UN, rule UN_mono, fact keys_idx_pm_of_pm_subset, auto simp: term_simps) also have "... = {0..<length bs}" by simp finally show ?thesis . qed lemma map2_mult_scalar_proj_poly_syz: "map2 mult_scalar xs (map (proj_poly_syz n) ys) = map (proj_poly_syz n ∘ (λ(x, y). mult_scalar x y)) (zip xs ys)" by (rule nth_equalityI, simp_all add: proj_poly_syz_mult_scalar) lemma map2_times_proj: "map2 (*) xs (map (proj_poly k) ys) = map (proj_poly k ∘ (λ(x, y). x ⊙ y)) (zip xs ys)" by (rule nth_equalityI, simp_all add: proj_mult_scalar) text ‹Probably the following lemma also holds without the distinctness constraint on ‹bs›.› lemma syzygy_module_list_subset: assumes "distinct bs" shows "syzygy_module_list bs ⊆ pmdl (set (init_syzygy_list bs))" proof let ?as = "init_syzygy_list bs" fix s assume "s ∈ syzygy_module_list bs" then obtain s' where s': "s' ∈ pmdl.syzygy_module (set bs)" and s: "s = atomize_poly (idx_pm_of_pm bs s')" by (rule syzygy_module_listE) from s' have "pmdl.represents (set bs) s' 0" by (rule pmdl.syzygy_moduleD) hence "keys s' ⊆ set bs" and 1: "0 = pmdl.rep s'" by (rule pmdl.representsD1, rule pmdl.representsD2) have "s = sum_list (map2 mult_scalar (cofactor_list_syz (length bs) s) (init_syzygy_list bs))" (is "_ = ?r") proof (rule poly_mapping_eqI_proj_syz) have "proj_poly_syz (length bs) ?r = sum_list (map2 mult_scalar (cofactor_list_syz (length bs) s) (map (proj_poly_syz (length bs)) (init_syzygy_list bs)))" by (simp add: proj_poly_syz_sum_list map2_mult_scalar_proj_poly_syz) also have "... = sum_list (map2 mult_scalar (cofactor_list_syz (length bs) s) bs)" by (simp add: proj_orig_basis_def[symmetric]) also have "... = sum_list (map (λb. mult_scalar (lookup s' b) b) bs)" proof (rule arg_cong[of _ _ sum_list], rule nth_equalityI, simp_all) fix i assume "i < length bs" with assms(1) have "lookup s' (bs ! i) = cofactor_list_syz (length bs) s ! i" by (simp add: s cofactor_list_syz_nth lookup_idx_pm_of_pm proj_atomize_poly) thus "mult_scalar (cofactor_list_syz (length bs) s ! i) (bs ! i) = mult_scalar (lookup s' (bs ! i)) (bs ! i)" by (simp only:) qed also have "... = (∑b∈set bs. mult_scalar (lookup s' b) b)" by (simp only: sum_code distinct_remdups_id[OF assms]) also have "... = (∑v∈keys s'. mult_scalar (lookup s' v) v)" by (rule sum.mono_neutral_right, fact finite_set, fact, simp add: in_keys_iff) also have "... = 0" by (simp add: 1 pmdl.rep_def) finally have eq: "proj_poly_syz (length bs) ?r = 0" . show "proj_poly_syz (length bs) s = proj_poly_syz (length bs) ?r" by (simp add: eq ‹s ∈ syzygy_module_list bs› proj_poly_syz_eq_zero_iff component_of_syzygy_module_list) next fix k assume "k < length bs" have "proj_poly k s = map2 (*) (cofactor_list_syz (length bs) s) (map (proj_poly k) (init_syzygy_list bs)) ! k" by (simp add: ‹k < length bs› init_syzygy_list_nth proj_lift_poly_syz cofactor_list_syz_nth) also have "... = sum_list (map2 (*) (cofactor_list_syz (length bs) s) (map (proj_poly k) (init_syzygy_list bs)))" by (rule sum_list_eq_nthI[symmetric], simp_all add: ‹k < length bs› init_syzygy_list_nth proj_lift_poly_syz) also have "... = proj_poly k ?r" by (simp add: proj_sum_list map2_times_proj) finally show "proj_poly k s = proj_poly k ?r" . qed also have "… ∈ pmdl (set (init_syzygy_list bs))" by (fact pmdl.span_listI) finally show "s ∈ pmdl (set (init_syzygy_list bs))" . qed subsubsection ‹Cofactors› lemma map2_mult_scalar_plus: "map2 (⊙) (map2 (+) xs ys) zs = map2 (+) (map2 (⊙) xs zs) (map2 (⊙) ys zs)" by (rule nth_equalityI, simp_all add: mult_scalar_distrib_right) lemma syz_cofactors: assumes "p ∈ pmdl (set (init_syzygy_list bs))" shows "proj_poly_syz (length bs) p = sum_list (map2 mult_scalar (cofactor_list_syz (length bs) p) bs)" using assms proof (induct rule: pmdl_induct) case module_0 show ?case by (simp, rule sum_list_zeroI', simp) next case (module_plus p b c t) from this(3) obtain i where i: "i < length bs" and b: "b = (init_syzygy_list bs) ! i" unfolding length_init_syzygy_list[symmetric, of bs] by (metis in_set_conv_nth) have "proj_poly_syz (length bs) (p + monom_mult c t b) = proj_poly_syz (length bs) p + monom_mult c t (bs ! i)" by (simp only: proj_poly_syz_plus proj_poly_syz_monom_mult b init_syzygy_list_nth[OF i] proj_poly_syz_lift_poly_syz[OF i]) also have "... = sum_list (map2 mult_scalar (cofactor_list_syz (length bs) p) bs) + monom_mult c t (bs ! i)" by (simp only: module_plus(2)) also have "... = sum_list (map2 mult_scalar (cofactor_list_syz (length bs) (p + monom_mult c t b)) bs)" proof (simp add: cofactor_list_syz_plus map2_mult_scalar_plus sum_list_map2_plus) have proj_b: "j < length bs ⟹ proj_poly j b = (1 when j = i)" for j by (simp add: b init_syzygy_list_nth i proj_lift_poly_syz) have eq: "j < length bs ⟹ (map2 mult_scalar (cofactor_list_syz (length bs) (monom_mult c t b)) bs) ! j = (monom_mult c t (bs ! i) when j = i)" for j by (simp add: cofactor_list_syz_nth proj_monom_mult proj_b mult_scalar_monom_mult when_def) have "sum_list (map2 mult_scalar (cofactor_list_syz (length bs) (monom_mult c t b)) bs) = (map2 mult_scalar (cofactor_list_syz (length bs) (monom_mult c t b)) bs) ! i" by (rule sum_list_eq_nthI, simp add: i, simp add: eq del: nth_zip nth_map) also have "... = mult_scalar (punit.monom_mult c t (proj_poly i b)) (bs ! i)" by (simp add: i cofactor_list_syz_nth proj_monom_mult) also have "... = monom_mult c t (bs ! i)" by (simp add: proj_b i mult_scalar_monomial times_monomial_left[symmetric]) finally show "monom_mult c t (bs ! i) = sum_list (map2 mult_scalar (cofactor_list_syz (length bs) (monom_mult c t b)) bs)" by (simp only:) qed finally show ?case . qed subsubsection ‹Modules› lemma pmdl_proj_orig_basis: assumes "pmdl (set gs) = pmdl (set (init_syzygy_list bs))" shows "pmdl (set (proj_orig_basis (length bs) gs)) = pmdl (set bs)" by (simp add: pmdl_proj_orig_basis' assms, simp only: pmdl_proj_orig_basis'[symmetric] proj_orig_basis_init_syzygy_list) lemma pmdl_filter_syzygy_basis_subset: assumes "distinct bs" and "pmdl (set gs) = pmdl (set (init_syzygy_list bs))" shows "pmdl (set (filter_syzygy_basis (length bs) gs)) ⊆ pmdl (syzygy_module_list bs)" proof (rule pmdl.span_mono, rule) fix s assume "s ∈ set (filter_syzygy_basis (length bs) gs)" hence "s ∈ set gs" and eq: "proj_poly_syz (length bs) s = 0" by (simp_all add: set_filter_syzygy_basis) from this(1) have "s ∈ pmdl (set gs)" by (rule pmdl.span_base) hence "s ∈ pmdl (set (init_syzygy_list bs))" by (simp only: assms) hence "proj_poly_syz (length bs) s = sum_list (map2 mult_scalar (cofactor_list_syz (length bs) s) bs)" by (rule syz_cofactors) hence "distinct bs" and "sum_list (map2 mult_scalar (cofactor_list_syz (length bs) s) bs) = 0" by (simp_all only: eq assms(1)) moreover from eq have "component_of_term ` keys s ⊆ {0..<length bs}" by (simp only: proj_poly_syz_eq_zero_iff) ultimately show "s ∈ syzygy_module_list bs" by (rule syzygy_module_listI') qed lemma ex_filter_syzygy_basis_adds_lt: assumes "is_pot_ord" and "distinct bs" and "is_Groebner_basis (set gs)" and "pmdl (set gs) = pmdl (set (init_syzygy_list bs))" and "f ∈ pmdl (syzygy_module_list bs)" and "f ≠ 0" shows "∃g∈set (filter_syzygy_basis (length bs) gs). g ≠ 0 ∧ lt g adds⇩t lt f" proof - from assms(5) have "f ∈ syzygy_module_list bs" by simp also from assms(2) have "... ⊆ pmdl (set (init_syzygy_list bs))" by (rule syzygy_module_list_subset) also have "... = pmdl (set gs)" by (simp only: assms(4)) finally have "f ∈ pmdl (set gs)" . with assms(3, 6) obtain g where "g ∈ set gs" and "g ≠ 0" and adds: "lt g adds⇩t lt f" unfolding GB_alt_3_finite[OF finite_set] by blast show ?thesis proof (intro bexI conjI) show "g ∈ set (filter_syzygy_basis (length bs) gs)" proof (simp add: set_filter_syzygy_basis, rule) show "proj_poly_syz (length bs) g = 0" proof (rule ccontr) assume "proj_poly_syz (length bs) g ≠ 0" with assms(1) have "length bs ≤ component_of_term (lt g)" by (rule component_of_lt_ge) also from adds have "... = component_of_term (lt f)" by (simp add: adds_term_def) also have "... < length bs" proof - from ‹f ≠ 0› have "lt f ∈ keys f" by (rule lt_in_keys) hence "component_of_term (lt f) ∈ component_of_term ` keys f" by (rule imageI) also from ‹f ∈ syzygy_module_list bs› have "... ⊆ {0..<length bs}" by (rule component_of_syzygy_module_list) finally show "component_of_term (lt f) < length bs" by simp qed finally show False .. qed qed fact qed fact+ qed lemma pmdl_filter_syzygy_basis: fixes bs::"('t ⇒⇩0 'b::field) list" assumes "is_pot_ord" and "distinct bs" and "is_Groebner_basis (set gs)" and "pmdl (set gs) = pmdl (set (init_syzygy_list bs))" shows "pmdl (set (filter_syzygy_basis (length bs) gs)) = syzygy_module_list bs" proof - from finite_set have "pmdl (set (filter_syzygy_basis (length bs) gs)) = pmdl (syzygy_module_list bs)" proof (rule pmdl_eqI_adds_lt_finite) from assms(2, 4) show "pmdl (set (filter_syzygy_basis (length bs) gs)) ⊆ pmdl (syzygy_module_list bs)" by (rule pmdl_filter_syzygy_basis_subset) next fix f assume "f ∈ pmdl (syzygy_module_list bs)" and "f ≠ 0" with assms show "∃g∈set (filter_syzygy_basis (length bs) gs). g ≠ 0 ∧ lt g adds⇩t lt f" by (rule ex_filter_syzygy_basis_adds_lt) qed thus ?thesis by simp qed subsubsection ‹Gr\"obner Bases› lemma proj_orig_basis_isGB: assumes "is_pot_ord" and "is_Groebner_basis (set gs)" and "pmdl (set gs) = pmdl (set (init_syzygy_list bs))" shows "is_Groebner_basis (set (proj_orig_basis (length bs) gs))" unfolding GB_alt_3_finite[OF finite_set] proof (intro ballI impI) fix f assume "f ∈ pmdl (set (proj_orig_basis (length bs) gs))" also have "... = proj_poly_syz (length bs) ` pmdl (set gs)" by (fact pmdl_proj_orig_basis') finally obtain h where "h ∈ pmdl (set gs)" and f: "f = proj_poly_syz (length bs) h" .. assume "f ≠ 0" with assms(1) have ltf: "lt f = map_component (λk. k - length bs) (lt h)" unfolding f by (rule lt_proj_poly_syz) from ‹f ≠ 0› have "h ≠ 0" by (auto simp add: f) with assms(2) ‹h ∈ pmdl (set gs)› obtain g where "g ∈ set gs" and "g ≠ 0" and "lt g adds⇩t lt h" unfolding GB_alt_3_finite[OF finite_set] by blast from this(3) have 1: "component_of_term (lt g) = component_of_term (lt h)" and 2: "pp_of_term (lt g) adds pp_of_term (lt h)" by (simp_all add: adds_term_def) let ?g = "proj_poly_syz (length bs) g" have "?g ≠ 0" proof (simp add: proj_poly_syz_eq_zero_iff, rule) assume "component_of_term ` keys g ⊆ {0..<length bs}" from assms(1) ‹f ≠ 0› have "length bs ≤ component_of_term (lt h)" unfolding f by (rule component_of_lt_ge) hence "component_of_term (lt g) ∉ {0..<length bs}" by (simp add: 1) moreover from ‹g ≠ 0› have "lt g ∈ keys g" by (rule lt_in_keys) ultimately show False using ‹component_of_term ` keys g ⊆ {0..<length bs}› by blast qed with assms(1) have ltg: "lt ?g = map_component (λk. k - length bs) (lt g)" by (rule lt_proj_poly_syz) show "∃g∈set (proj_orig_basis (length bs) gs). g ≠ 0 ∧ lt g adds⇩t lt f" proof (intro bexI conjI) show "lt ?g adds⇩t lt f" by (simp add: ltf ltg adds_term_def 1 2 term_simps) next show "?g ∈ set (proj_orig_basis (length bs) gs)" unfolding set_proj_orig_basis using ‹g ∈ set gs› by (rule imageI) qed fact qed lemma filter_syzygy_basis_isGB: assumes "is_pot_ord" and "distinct bs" and "is_Groebner_basis (set gs)" and "pmdl (set gs) = pmdl (set (init_syzygy_list bs))" shows "is_Groebner_basis (set (filter_syzygy_basis (length bs) gs))" unfolding GB_alt_3_finite[OF finite_set] proof (intro ballI impI) fix f::"'t ⇒⇩0 'b" assume "f ≠ 0" assume "f ∈ pmdl (set (filter_syzygy_basis (length bs) gs))" also from assms have "... = syzygy_module_list bs" by (rule pmdl_filter_syzygy_basis) finally have "f ∈ pmdl (syzygy_module_list bs)" by simp from assms this ‹f ≠ 0› show "∃g∈set (filter_syzygy_basis (length bs) gs). g ≠ 0 ∧ lt g adds⇩t lt f" by (rule ex_filter_syzygy_basis_adds_lt) qed end (* gd_inf_term *) end (* theory *)
Theory Syzygy_Examples
(* Author: Alexander Maletzky *) section ‹Sample Computations of Syzygies› theory Syzygy_Examples imports Buchberger Algorithm_Schema_Impl Syzygy Code_Target_Rat begin subsection ‹Preparations› text ‹We must define the following four constants outside the global interpretation, since otherwise their types are too general.› definition splus_pprod :: "('a::nat, 'b::nat) pp ⇒ _" where "splus_pprod = pprod.splus" definition monom_mult_pprod :: "'c::semiring_0 ⇒ ('a::nat, 'b::nat) pp ⇒ ((('a, 'b) pp × nat) ⇒⇩0 'c) ⇒ _" where "monom_mult_pprod = pprod.monom_mult" definition mult_scalar_pprod :: "(('a::nat, 'b::nat) pp ⇒⇩0 'c::semiring_0) ⇒ ((('a, 'b) pp × nat) ⇒⇩0 'c) ⇒ _" where "mult_scalar_pprod = pprod.mult_scalar" definition adds_term_pprod :: "(('a::nat, 'b::nat) pp × _) ⇒ _" where "adds_term_pprod = pprod.adds_term" lemma (in gd_term) compute_trd_aux [code]: "trd_aux fs p r = (if is_zero p then r else case find_adds fs (lt p) of None ⇒ trd_aux fs (tail p) (plus_monomial_less r (lc p) (lt p)) | Some f ⇒ trd_aux fs (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f)) r )" by (simp only: trd_aux.simps[of fs p r] plus_monomial_less_def is_zero_def) locale gd_nat_inf_term = gd_nat_term pair_of_term term_of_pair cmp_term for pair_of_term::"'t::nat_term ⇒ ('a::{nat_term,graded_dickson_powerprod} × nat)" and term_of_pair::"('a × nat) ⇒ 't" and cmp_term begin sublocale aux: gd_inf_term pair_of_term term_of_pair "λs t. le_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min))" "λs t. lt_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min))" "le_of_nat_term_order cmp_term" "lt_of_nat_term_order cmp_term" .. definition lift_keys :: "nat ⇒ ('t, 'b) oalist_ntm ⇒ ('t, 'b::semiring_0) oalist_ntm" where "lift_keys i xs = oalist_of_list_ntm (map_raw (λkv. (map_component ((+) i) (fst kv), snd kv)) (list_of_oalist_ntm xs))" lemma list_of_oalist_lift_keys: "list_of_oalist_ntm (lift_keys i xs) = (map_raw (λkv. (map_component ((+) i) (fst kv), snd kv)) (list_of_oalist_ntm xs))" unfolding lift_keys_def oops text ‹Regardless of whether the above lemma holds (which might be the case) or not, we can use @{const lift_keys} in computations. Now, however, it is implemented rather inefficiently, because the list resulting from the application of @{const map_raw} is sorted again. That should not be a big problem though, since @{const lift_keys} is applied only once to every input polynomial before computing syzygies.› lemma lookup_lift_keys_plus: "lookup (MP_oalist (lift_keys i xs)) (term_of_pair (t, i + k)) = lookup (MP_oalist xs) (term_of_pair (t, k))" (is "?l = ?r") proof - let ?f = "λkv::'t × 'b. (map_component ((+) i) (fst kv), snd kv)" obtain xs' ox where xs: "list_of_oalist_ntm xs = (xs', ox)" by fastforce from oalist_inv_list_of_oalist_ntm[of xs] have inv: "ko_ntm.oalist_inv_raw ox xs'" by (simp add: xs ko_ntm.oalist_inv_def nat_term_compare_inv_conv) let ?rel = "ko.lt (key_order_of_nat_term_order_inv ox)" have "irreflp ?rel" by (simp add: irreflp_def) moreover have "transp ?rel" by (simp add: lt_of_nat_term_order_alt) moreover from oa_ntm.list_of_oalist_sorted[of xs] have "sorted_wrt (ko.lt (key_order_of_nat_term_order_inv ox)) (map fst xs')" by (simp add: xs) ultimately have dist1: "distinct (map fst xs')" by (rule distinct_sorted_wrt_irrefl) have 1: "u = v" if "map_component ((+) i) u = map_component ((+) i) v" for u v proof - have "inj ((+) i)" by (simp add: inj_def) thus ?thesis using that by (rule map_component_inj) qed have dist2: "distinct (map fst (map_pair (λkv. (map_component ((+) i) (fst kv), snd kv)) xs'))" by (rule ko_ntm.distinct_map_pair, fact dist1, simp add: 1) have "?l = lookup_dflt (map_pair ?f xs') (term_of_pair (t, i + k))" by (simp add: oa_ntm.lookup_def lift_keys_def xs oalist_of_list_ntm_def list_of_oalist_OAlist_ntm ko_ntm.lookup_pair_sort_oalist'[OF dist2]) also have "... = lookup_dflt (map_pair ?f xs') (fst (?f (term_of_pair (t, k), b)))" by (simp add: map_component_term_of_pair) also have "... = snd (?f (term_of_pair (t, k), lookup_dflt xs' (term_of_pair (t, k))))" by (rule ko_ntm.lookup_dflt_map_pair, fact dist1, auto intro: 1) also have "... = ?r" by (simp add: oa_ntm.lookup_def xs ko_ntm.lookup_dflt_eq_lookup_pair[OF inv]) finally show ?thesis . qed lemma keys_lift_keys_subset: "keys (MP_oalist (lift_keys i xs)) ⊆ (map_component ((+) i)) ` keys (MP_oalist xs)" (is "?l ⊆ ?r") proof - let ?f = "λkv::'t × 'b. (map_component ((+) i) (fst kv), snd kv)" obtain xs' ox where xs: "list_of_oalist_ntm xs = (xs', ox)" by fastforce let ?rel = "ko.lt (key_order_of_nat_term_order_inv ox)" have "irreflp ?rel" by (simp add: irreflp_def) moreover have "transp ?rel" by (simp add: lt_of_nat_term_order_alt) moreover from oa_ntm.list_of_oalist_sorted[of xs] have "sorted_wrt (ko.lt (key_order_of_nat_term_order_inv ox)) (map fst xs')" by (simp add: xs) ultimately have dist1: "distinct (map fst xs')" by (rule distinct_sorted_wrt_irrefl) have 1: "u = v" if "map_component ((+) i) u = map_component ((+) i) v" for u v proof - have "inj ((+) i)" by (simp add: inj_def) thus ?thesis using that by (rule map_component_inj) qed have dist2: "distinct (map fst (map_pair (λkv. (map_component ((+) i) (fst kv), snd kv)) xs'))" by (rule ko_ntm.distinct_map_pair, fact dist1, simp add: 1) have "?l ⊆ fst ` set (fst (map_raw ?f (list_of_oalist_ntm xs)))" by (auto simp: keys_MP_oalist lift_keys_def oalist_of_list_ntm_def list_of_oalist_OAlist_ntm xs ko_ntm.set_sort_oalist[OF dist2]) also from ko_ntm.map_raw_subset have "... ⊆ fst ` ?f ` set (fst (list_of_oalist_ntm xs))" by (rule image_mono) also have "... ⊆ ?r" by (simp add: keys_MP_oalist image_image) finally show ?thesis . qed end global_interpretation pprod': gd_nat_inf_term "λx::('a, 'b) pp × nat. x" "λx. x" cmp_term rewrites "pprod.pp_of_term = fst" and "pprod.component_of_term = snd" and "pprod.splus = splus_pprod" and "pprod.monom_mult = monom_mult_pprod" and "pprod.mult_scalar = mult_scalar_pprod" and "pprod.adds_term = adds_term_pprod" for cmp_term :: "(('a::nat, 'b::nat) pp × nat) nat_term_order" defines shift_map_keys_pprod = pprod'.shift_map_keys and lift_keys_pprod = pprod'.lift_keys and min_term_pprod = pprod'.min_term and lt_pprod = pprod'.lt and lc_pprod = pprod'.lc and tail_pprod = pprod'.tail and comp_opt_p_pprod = pprod'.comp_opt_p and ord_p_pprod = pprod'.ord_p and ord_strict_p_pprod = pprod'.ord_strict_p and find_adds_pprod = pprod'.find_adds and trd_aux_pprod= pprod'.trd_aux and trd_pprod = pprod'.trd and spoly_pprod = pprod'.spoly and count_const_lt_components_pprod = pprod'.count_const_lt_components and count_rem_components_pprod = pprod'.count_rem_components and const_lt_component_pprod = pprod'.const_lt_component and full_gb_pprod = pprod'.full_gb and keys_to_list_pprod = pprod'.keys_to_list and Keys_to_list_pprod = pprod'.Keys_to_list and add_pairs_single_sorted_pprod = pprod'.add_pairs_single_sorted and add_pairs_pprod = pprod'.add_pairs and canon_pair_order_aux_pprod = pprod'.canon_pair_order_aux and canon_basis_order_pprod = pprod'.canon_basis_order and new_pairs_sorted_pprod = pprod'.new_pairs_sorted and component_crit_pprod = pprod'.component_crit and chain_ncrit_pprod = pprod'.chain_ncrit and chain_ocrit_pprod = pprod'.chain_ocrit and apply_icrit_pprod = pprod'.apply_icrit and apply_ncrit_pprod = pprod'.apply_ncrit and apply_ocrit_pprod = pprod'.apply_ocrit and trdsp_pprod = pprod'.trdsp and gb_sel_pprod = pprod'.gb_sel and gb_red_aux_pprod = pprod'.gb_red_aux and gb_red_pprod = pprod'.gb_red and gb_aux_pprod = pprod'.gb_aux and gb_pprod = pprod'.gb and filter_syzygy_basis_pprod = pprod'.aux.filter_syzygy_basis and init_syzygy_list_pprod = pprod'.aux.init_syzygy_list and lift_poly_syz_pprod = pprod'.aux.lift_poly_syz and map_component_pprod = pprod'.map_component subgoal by (rule gd_nat_inf_term.intro, fact gd_nat_term_id) subgoal by (fact pprod_pp_of_term) subgoal by (fact pprod_component_of_term) subgoal by (simp only: splus_pprod_def) subgoal by (simp only: monom_mult_pprod_def) subgoal by (simp only: mult_scalar_pprod_def) subgoal by (simp only: adds_term_pprod_def) done lemma compute_adds_term_pprod [code]: "adds_term_pprod u v = (snd u = snd v ∧ adds_pp_add_linorder (fst u) (fst v))" by (simp add: adds_term_pprod_def pprod.adds_term_def adds_pp_add_linorder_def) lemma compute_splus_pprod [code]: "splus_pprod t (s, i) = (t + s, i)" by (simp add: splus_pprod_def pprod.splus_def) lemma compute_shift_map_keys_pprod [code abstract]: "list_of_oalist_ntm (shift_map_keys_pprod t f xs) = map_raw (λ(k, v). (splus_pprod t k, f v)) (list_of_oalist_ntm xs)" by (simp add: pprod'.list_of_oalist_shift_keys case_prod_beta') lemma compute_trd_pprod [code]: "trd_pprod to fs p = trd_aux_pprod to fs p (change_ord to 0)" by (simp only: pprod'.trd_def change_ord_def) lemmas [code] = conversep_iff lemma POT_is_pot_ord: "pprod'.is_pot_ord (TYPE('a::nat)) (TYPE('b::nat)) (POT to)" by (rule pprod'.is_pot_ordI, simp add: lt_of_nat_term_order nat_term_compare_POT pot_comp rep_nat_term_prod_def, simp add: comparator_of_def) definition Vec⇩0 :: "nat ⇒ (('a, nat) pp ⇒⇩0 'b) ⇒ (('a::nat, nat) pp × nat) ⇒⇩0 'b::semiring_1" where "Vec⇩0 i p = mult_scalar_pprod p (Poly_Mapping.single (0, i) 1)" definition "syzygy_basis to bs = filter_syzygy_basis_pprod (length bs) (map fst (gb_pprod (POT to) (map (λp. (p, ())) (init_syzygy_list_pprod bs)) ()))" thm pprod'.aux.filter_syzygy_basis_isGB[OF POT_is_pot_ord] lemma lift_poly_syz_MP_oalist [code]: "lift_poly_syz_pprod n (MP_oalist xs) i = MP_oalist (OAlist_insert_ntm ((0, i), 1) (lift_keys_pprod n xs))" proof (rule poly_mapping_eqI, simp add: pprod'.aux.lookup_lift_poly_syz del: MP_oalist.rep_eq, intro conjI impI) fix v::"('a, 'b) pp × nat" assume "n ≤ snd v" moreover obtain t k where "v = (t, k)" by fastforce ultimately have k: "n + (k - n) = k" by simp hence v: "v = (t, n + (k - n))" by (simp only: ‹v = (t, k)›) assume "v ≠ (0, i)" hence "lookup (MP_oalist (OAlist_insert_ntm ((0, i), 1) (lift_keys_pprod n xs))) v = lookup (MP_oalist (lift_keys_pprod n xs)) v" by (simp add: oa_ntm.lookup_insert) also have "... = lookup (MP_oalist xs) (t, k - n)" by (simp only: v pprod'.lookup_lift_keys_plus) also have "... = lookup (MP_oalist xs) (map_component_pprod (λk. k - n) v)" by (simp add: v pprod'.map_component_term_of_pair) finally show "lookup (MP_oalist xs) (map_component_pprod (λk. k - n) v) = lookup (MP_oalist (OAlist_insert_ntm ((0, i), 1) (lift_keys_pprod n xs))) v" by (rule HOL.sym) next fix v::"('a, 'b) pp × nat" assume "¬ n ≤ snd v" assume "v ≠ (0, i)" hence "lookup (MP_oalist (OAlist_insert_ntm ((0, i), 1) (lift_keys_pprod n xs))) v = lookup (MP_oalist (lift_keys_pprod n xs)) v" by (simp add: add: oa_ntm.lookup_insert) also have "... = 0" proof (rule ccontr) assume "lookup (MP_oalist (lift_keys_pprod n xs)) v ≠ 0" hence "v ∈ keys (MP_oalist (lift_keys_pprod n xs))" by (simp add: in_keys_iff del: MP_oalist.rep_eq) also have "... ⊆ map_component_pprod ((+) n) ` keys (MP_oalist xs)" by (fact pprod'.keys_lift_keys_subset) finally obtain u where "v = map_component_pprod ((+) n) u" .. hence "snd v = n + snd u" by (simp add: pprod'.component_of_map_component) with ‹¬ n ≤ snd v› show False by simp qed finally show "lookup (MP_oalist (OAlist_insert_ntm ((0, i), 1) (lift_keys_pprod n xs))) v = 0" . qed (simp_all add: oa_ntm.lookup_insert) subsection ‹Computations› experiment begin interpretation trivariate⇩0_rat . lemma "syzygy_basis DRLEX [Vec⇩0 0 (X⇧2 * Z ^ 3 + 3 * X⇧2 * Y), Vec⇩0 0 (X * Y * Z + 2 * Y⇧2)] = [Vec⇩0 0 (C⇩0 (1 / 3) * X * Y * Z + C⇩0 (2 / 3) * Y⇧2) + Vec⇩0 1 (C⇩0 (- 1 / 3) * X⇧2 * Z ^ 3 - X⇧2 * Y)]" by eval value [code] "syzygy_basis DRLEX [Vec⇩0 0 (X⇧2 * Z ^ 3 + 3 * X⇧2 * Y), Vec⇩0 0 (X * Y * Z + 2 * Y⇧2), Vec⇩0 0 (X - Y + 3 * Z)]" lemma "map fst (gb_pprod (POT DRLEX) (map (λp. (p, ())) (init_syzygy_list_pprod [Vec⇩0 0 (X ^ 4 + 3 * X⇧2 * Y), Vec⇩0 0 (Y ^ 3 + 2 * X * Z), Vec⇩0 0 (Z⇧2 - X - Y)])) ()) = [ Vec⇩0 0 1 + Vec⇩0 3 (X ^ 4 + 3 * X⇧2 * Y), Vec⇩0 1 1 + Vec⇩0 3 (Y ^ 3 + 2 * X * Z), Vec⇩0 0 (Y ^ 3 + 2 * X * Z) - Vec⇩0 1 (X ^ 4 + 3 * X⇧2 * Y), Vec⇩0 2 1 + Vec⇩0 3 (Z⇧2 - X - Y), Vec⇩0 1 (Z⇧2 - X - Y) - Vec⇩0 2 (Y ^ 3 + 2 * X * Z), Vec⇩0 0 (Z⇧2 - X - Y) - Vec⇩0 2 (X ^ 4 + 3 * X⇧2 * Y), Vec⇩0 0 (- (Y ^ 3 * Z⇧2) + Y ^ 4 + X * Y ^ 3 + 2 * X⇧2 * Z + 2 * X * Y * Z - 2 * X * Z ^ 3) + Vec⇩0 1 (X ^ 4 * Z⇧2 - X ^ 5 - X ^ 4 * Y - 3 * X ^ 3 * Y - 3 * X⇧2 * Y⇧2 + 3 * X⇧2 * Y * Z⇧2) ]" by eval lemma "syzygy_basis DRLEX [Vec⇩0 0 (X ^ 4 + 3 * X⇧2 * Y), Vec⇩0 0 (Y ^ 3 + 2 * X * Z), Vec⇩0 0 (Z⇧2 - X - Y)] = [ Vec⇩0 0 (Y ^ 3 + 2 * X * Z) - Vec⇩0 1 (X ^ 4 + 3 * X⇧2 * Y), Vec⇩0 1 (Z⇧2 - X - Y) - Vec⇩0 2 (Y ^ 3 + 2 * X * Z), Vec⇩0 0 (Z⇧2 - X - Y) - Vec⇩0 2 (X ^ 4 + 3 * X⇧2 * Y), Vec⇩0 0 (- (Y ^ 3 * Z⇧2) + Y ^ 4 + X * Y ^ 3 + 2 * X⇧2 * Z + 2 * X * Y * Z - 2 * X * Z ^ 3) + Vec⇩0 1 (X ^ 4 * Z⇧2 - X ^ 5 - X ^ 4 * Y - 3 * X ^ 3 * Y - 3 * X⇧2 * Y⇧2 + 3 * X⇧2 * Y * Z⇧2) ]" by eval value [code] "syzygy_basis DRLEX [Vec⇩0 0 (X * Y - Z), Vec⇩0 0 (X * Z - Y), Vec⇩0 0 (Y * Z - X)]" lemma "map fst (gb_pprod (POT DRLEX) (map (λp. (p, ())) (init_syzygy_list_pprod [Vec⇩0 0 (X * Y - Z), Vec⇩0 0 (X * Z - Y), Vec⇩0 0 (Y * Z - X)])) ()) = [ Vec⇩0 0 1 + Vec⇩0 3 (X * Y - Z), Vec⇩0 1 1 + Vec⇩0 3 (X * Z - Y), Vec⇩0 2 1 + Vec⇩0 3 (Y * Z - X), Vec⇩0 0 (- X * Z + Y) + Vec⇩0 1 (X * Y - Z), Vec⇩0 0 (- Y * Z + X) + Vec⇩0 2 (X * Y - Z), Vec⇩0 1 (- Y * Z + X) + Vec⇩0 2 (X * Z - Y), Vec⇩0 1 (-Y) + Vec⇩0 2 (X) + Vec⇩0 3 (Y ^ 2 - X ^ 2), Vec⇩0 0 (Z) + Vec⇩0 2 (-X) + Vec⇩0 3 (X ^ 2 - Z ^ 2), Vec⇩0 0 (Y - Y * Z ^ 2) + Vec⇩0 1 (Y ^ 2 * Z - Z) + Vec⇩0 2 (Y ^ 2 - Z ^ 2), Vec⇩0 0 (- Y) + Vec⇩0 1 (- (X * Y)) + Vec⇩0 2 (X ^ 2 - 1) + Vec⇩0 3 (X - X ^ 3) ]" by eval lemma "syzygy_basis DRLEX [Vec⇩0 0 (X * Y - Z), Vec⇩0 0 (X * Z - Y), Vec⇩0 0 (Y * Z - X)] = [ Vec⇩0 0 (- X * Z + Y) + Vec⇩0 1 (X * Y - Z), Vec⇩0 0 (- Y * Z + X) + Vec⇩0 2 (X * Y - Z), Vec⇩0 1 (- Y * Z + X) + Vec⇩0 2 (X * Z - Y), Vec⇩0 0 (Y - Y * Z ^ 2) + Vec⇩0 1 (Y ^ 2 * Z - Z) + Vec⇩0 2 (Y ^ 2 - Z ^ 2) ]" by eval end end (* theory *)
Theory Groebner_PM
(* Author: Alexander Maletzky *) theory Groebner_PM imports Polynomials.MPoly_PM Reduced_GB begin text ‹We prove results that hold specifically for Gr\"obner bases in polynomial rings, where the polynomials really have @{emph ‹indeterminates›}.› context pm_powerprod begin lemmas finite_reduced_GB_Polys = punit.finite_reduced_GB_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum] lemmas reduced_GB_is_reduced_GB_Polys = punit.reduced_GB_is_reduced_GB_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum] lemmas reduced_GB_is_GB_Polys = punit.reduced_GB_is_GB_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum] lemmas reduced_GB_is_auto_reduced_Polys = punit.reduced_GB_is_auto_reduced_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum] lemmas reduced_GB_is_monic_set_Polys = punit.reduced_GB_is_monic_set_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum] lemmas reduced_GB_nonzero_Polys = punit.reduced_GB_nonzero_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum] lemmas reduced_GB_ideal_Polys = punit.reduced_GB_pmdl_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum] lemmas reduced_GB_unique_Polys = punit.reduced_GB_unique_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum] lemmas reduced_GB_Polys = punit.reduced_GB_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum] lemmas ideal_eq_UNIV_iff_reduced_GB_eq_one_Polys = ideal_eq_UNIV_iff_reduced_GB_eq_one_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum] subsection ‹Univariate Polynomials› lemma (in -) adds_univariate_linear: assumes "finite X" and "card X ≤ 1" and "s ∈ .[X]" and "t ∈ .[X]" obtains "s adds t" | "t adds s" proof (cases "s adds t") case True thus ?thesis .. next case False then obtain x where 1: "lookup t x < lookup s x" by (auto simp: adds_poly_mapping le_fun_def not_le) hence "x ∈ keys s" by (simp add: in_keys_iff) also from assms(3) have "… ⊆ X" by (rule PPsD) finally have "x ∈ X" . have "t adds s" unfolding adds_poly_mapping le_fun_def proof fix y show "lookup t y ≤ lookup s y" proof (cases "y ∈ keys t") case True also from assms(4) have "keys t ⊆ X" by (rule PPsD) finally have "y ∈ X" . with assms(1, 2) ‹x ∈ X› have "x = y" by (simp add: card_le_Suc0_iff_eq) with 1 show ?thesis by simp next case False thus ?thesis by (simp add: in_keys_iff) qed qed thus ?thesis .. qed context fixes X :: "'x set" assumes fin_X: "finite X" and card_X: "card X ≤ 1" begin lemma ord_iff_adds_univariate: assumes "s ∈ .[X]" and "t ∈ .[X]" shows "s ≼ t ⟷ s adds t" proof assume "s ≼ t" from fin_X card_X assms show "s adds t" proof (rule adds_univariate_linear) assume "t adds s" hence "t ≼ s" by (rule ord_adds) with ‹s ≼ t› have "s = t" by simp thus ?thesis by simp qed qed (rule ord_adds) lemma adds_iff_deg_le_univariate: assumes "s ∈ .[X]" and "t ∈ .[X]" shows "s adds t ⟷ deg_pm s ≤ deg_pm t" proof assume *: "deg_pm s ≤ deg_pm t" from fin_X card_X assms show "s adds t" proof (rule adds_univariate_linear) assume "t adds s" hence "t = s" using * by (rule adds_deg_pm_antisym) thus ?thesis by simp qed qed (rule deg_pm_mono) corollary ord_iff_deg_le_univariate: "s ∈ .[X] ⟹ t ∈ .[X] ⟹ s ≼ t ⟷ deg_pm s ≤ deg_pm t" by (simp only: ord_iff_adds_univariate adds_iff_deg_le_univariate) lemma poly_deg_univariate: assumes "p ∈ P[X]" shows "poly_deg p = deg_pm (lpp p)" proof (cases "p = 0") case True thus ?thesis by simp next case False hence lp_in: "lpp p ∈ keys p" by (rule punit.lt_in_keys) also from assms have "… ⊆ .[X]" by (rule PolysD) finally have "lpp p ∈ .[X]" . show ?thesis proof (intro antisym poly_deg_leI) fix t assume "t ∈ keys p" hence "t ≼ lpp p" by (rule punit.lt_max_keys) moreover from ‹t ∈ keys p› ‹keys p ⊆ .[X]› have "t ∈ .[X]" .. ultimately show "deg_pm t ≤ deg_pm (lpp p)" using ‹lpp p ∈ .[X]› by (simp only: ord_iff_deg_le_univariate) next from lp_in show "deg_pm (lpp p) ≤ poly_deg p" by (rule poly_deg_max_keys) qed qed lemma reduced_GB_univariate_cases: assumes "F ⊆ P[X]" obtains g where "g ∈ P[X]" and "g ≠ 0" and "lcf g = 1" and "punit.reduced_GB F = {g}" | "punit.reduced_GB F = {}" proof (cases "punit.reduced_GB F = {}") case True thus ?thesis .. next case False let ?G = "punit.reduced_GB F" from fin_X assms have ar: "punit.is_auto_reduced ?G" and "0 ∉ ?G" and "?G ⊆ P[X]" and m: "punit.is_monic_set ?G" by (rule reduced_GB_is_auto_reduced_Polys, rule reduced_GB_nonzero_Polys, rule reduced_GB_Polys, rule reduced_GB_is_monic_set_Polys) from False obtain g where "g ∈ ?G" by blast with ‹0 ∉ ?G› ‹?G ⊆ P[X]› have "g ≠ 0" and "g ∈ P[X]" by blast+ from this(1) have lp_g: "lpp g ∈ keys g" by (rule punit.lt_in_keys) also from ‹g ∈ P[X]› have "… ⊆ .[X]" by (rule PolysD) finally have "lpp g ∈ .[X]" . note ‹g ∈ P[X]› ‹g ≠ 0› moreover from m ‹g ∈ ?G› ‹g ≠ 0› have "lcf g = 1" by (rule punit.is_monic_setD) moreover have "?G = {g}" proof show "?G ⊆ {g}" proof fix g' assume "g' ∈ ?G" with ‹0 ∉ ?G› ‹?G ⊆ P[X]› have "g' ≠ 0" and "g' ∈ P[X]" by blast+ from this(1) have lp_g': "lpp g' ∈ keys g'" by (rule punit.lt_in_keys) also from ‹g' ∈ P[X]› have "… ⊆ .[X]" by (rule PolysD) finally have "lpp g' ∈ .[X]" . have "g' = g" proof (rule ccontr) assume "g' ≠ g" with ‹g ∈ ?G› ‹g' ∈ ?G› have g: "g ∈ ?G - {g'}" and g': "g' ∈ ?G - {g}" by blast+ from fin_X card_X ‹lpp g ∈ .[X]› ‹lpp g' ∈ .[X]› show False proof (rule adds_univariate_linear) assume *: "lpp g adds lpp g'" from ar ‹g' ∈ ?G› have "¬ punit.is_red (?G - {g'}) g'" by (rule punit.is_auto_reducedD) moreover from g ‹g ≠ 0› lp_g' * have "punit.is_red (?G - {g'}) g'" by (rule punit.is_red_addsI[simplified]) ultimately show ?thesis .. next assume *: "lpp g' adds lpp g" from ar ‹g ∈ ?G› have "¬ punit.is_red (?G - {g}) g" by (rule punit.is_auto_reducedD) moreover from g' ‹g' ≠ 0› lp_g * have "punit.is_red (?G - {g}) g" by (rule punit.is_red_addsI[simplified]) ultimately show ?thesis .. qed qed thus "g' ∈ {g}" by simp qed next from ‹g ∈ ?G› show "{g} ⊆ ?G" by simp qed ultimately show ?thesis .. qed corollary deg_reduced_GB_univariate_le: assumes "F ⊆ P[X]" and "f ∈ ideal F" and "f ≠ 0" and "g ∈ punit.reduced_GB F" shows "poly_deg g ≤ poly_deg f" using assms(1) proof (rule reduced_GB_univariate_cases) let ?G = "punit.reduced_GB F" fix g' assume "g' ∈ P[X]" and "g' ≠ 0" and G: "?G = {g'}" from fin_X assms(1) have gb: "punit.is_Groebner_basis ?G" and "ideal ?G = ideal F" and "?G ⊆ P[X]" by (rule reduced_GB_is_GB_Polys, rule reduced_GB_ideal_Polys, rule reduced_GB_Polys) from assms(2) this(2) have "f ∈ ideal ?G" by simp with gb obtain g'' where "g'' ∈ ?G" and "lpp g'' adds lpp f" using assms(3) by (rule punit.GB_adds_lt[simplified]) with assms(4) have "lpp g adds lpp f" by (simp add: G) hence "deg_pm (lpp g) ≤ deg_pm (lpp f)" by (rule deg_pm_mono) moreover from assms(4) ‹?G ⊆ P[X]› have "g ∈ P[X]" .. ultimately have "poly_deg g ≤ deg_pm (lpp f)" by (simp only: poly_deg_univariate) also from punit.lt_in_keys have "… ≤ poly_deg f" by (rule poly_deg_max_keys) fact finally show ?thesis . next assume "punit.reduced_GB F = {}" with assms(4) show ?thesis by simp qed end subsection ‹Homogeneity› lemma is_reduced_GB_homogeneous: assumes "⋀f. f ∈ F ⟹ homogeneous f" and "punit.is_reduced_GB G" and "ideal G = ideal F" and "g ∈ G" shows "homogeneous g" proof (rule homogeneousI) fix s t have 1: "deg_pm u = deg_pm (lpp g)" if "u ∈ keys g" for u proof - from assms(4) have "g ∈ ideal G" by (rule ideal.span_base) hence "g ∈ ideal F" by (simp only: assms(3)) from that have "u ∈ Keys (hom_components g)" by (simp only: Keys_hom_components) then obtain q where q: "q ∈ hom_components g" and "u ∈ keys q" by (rule in_KeysE) from assms(1) ‹g ∈ ideal F› q have "q ∈ ideal F" by (rule homogeneous_ideal') from assms(2) have "punit.is_Groebner_basis G" by (rule punit.reduced_GB_D1) moreover from ‹q ∈ ideal F› have "q ∈ ideal G" by (simp only: assms(3)) moreover from q have "q ≠ 0" by (rule hom_components_nonzero) ultimately obtain g' where "g' ∈ G" and "g' ≠ 0" and adds: "lpp g' adds lpp q" by (rule punit.GB_adds_lt[simplified]) from ‹q ≠ 0› have "lpp q ∈ keys q" by (rule punit.lt_in_keys) also from q have "… ⊆ Keys (hom_components g)" by (rule keys_subset_Keys) finally have "lpp q ∈ keys g" by (simp only: Keys_hom_components) with _ ‹g' ≠ 0› have red: "punit.is_red {g'} g" using adds by (rule punit.is_red_addsI[simplified]) simp from assms(2) have "punit.is_auto_reduced G" by (rule punit.reduced_GB_D2) hence "¬ punit.is_red (G - {g}) g" using assms(4) by (rule punit.is_auto_reducedD) with red have "¬ {g'} ⊆ G - {g}" using punit.is_red_subset by blast with ‹g' ∈ G› have "g' = g" by simp from ‹lpp q ∈ keys g› have "lpp q ≼ lpp g" by (rule punit.lt_max_keys) moreover from adds have "lpp g ≼ lpp q" unfolding ‹g' = g› by (rule punit.ord_adds_term[simplified]) ultimately have eq: "lpp q = lpp g" by simp from q have "homogeneous q" by (rule hom_components_homogeneous) hence "deg_pm u = deg_pm (lpp q)" using ‹u ∈ keys q› ‹lpp q ∈ keys q› by (rule homogeneousD) thus ?thesis by (simp only: eq) qed assume "s ∈ keys g" hence 2: "deg_pm s = deg_pm (lpp g)" by (rule 1) assume "t ∈ keys g" hence "deg_pm t = deg_pm (lpp g)" by (rule 1) with 2 show "deg_pm s = deg_pm t" by simp qed lemma lp_dehomogenize: assumes "is_hom_ord x" and "homogeneous p" shows "lpp (dehomogenize x p) = except (lpp p) {x}" proof (cases "p = 0") case True thus ?thesis by simp next case False hence "lpp p ∈ keys p" by (rule punit.lt_in_keys) with assms(2) have "except (lpp p) {x} ∈ keys (dehomogenize x p)" by (rule keys_dehomogenizeI) thus ?thesis proof (rule punit.lt_eqI_keys) fix t assume "t ∈ keys (dehomogenize x p)" then obtain s where "s ∈ keys p" and t: "t = except s {x}" by (rule keys_dehomogenizeE) from this(1) have "s ≼ lpp p" by (rule punit.lt_max_keys) moreover from assms(2) ‹s ∈ keys p› ‹lpp p ∈ keys p› have "deg_pm s = deg_pm (lpp p)" by (rule homogeneousD) ultimately show "t ≼ except (lpp p) {x}" using assms(1) by (simp add: t is_hom_ordD) qed qed lemma isGB_dehomogenize: assumes "is_hom_ord x" and "finite X" and "G ⊆ P[X]" and "punit.is_Groebner_basis G" and "⋀g. g ∈ G ⟹ homogeneous g" shows "punit.is_Groebner_basis (dehomogenize x ` G)" using dickson_grading_varnum proof (rule punit.isGB_I_adds_lt[simplified]) from assms(2) show "finite (X - {x})" by simp next have "dehomogenize x ` G ⊆ P[X - {x}]" proof fix g assume "g ∈ dehomogenize x ` G" then obtain g' where "g' ∈ G" and g: "g = dehomogenize x g'" .. from this(1) assms(3) have "g' ∈ P[X]" .. hence "indets g' ⊆ X" by (rule PolysD) have "indets g ⊆ indets g' - {x}" by (simp only: g indets_dehomogenize) also from ‹indets g' ⊆ X› subset_refl have "… ⊆ X - {x}" by (rule Diff_mono) finally show "g ∈ P[X - {x}]" by (rule PolysI_alt) qed thus "dehomogenize x ` G ⊆ punit.dgrad_p_set (varnum (X - {x})) 0" by (simp only: dgrad_p_set_varnum) next fix p assume "p ∈ ideal (dehomogenize x ` G)" then obtain G0 q where "G0 ⊆ dehomogenize x ` G" and "finite G0" and p: "p = (∑g∈G0. q g * g)" by (rule ideal.spanE) from this(1) obtain G' where "G' ⊆ G" and G0: "G0 = dehomogenize x ` G'" and inj: "inj_on (dehomogenize x) G'" by (rule subset_imageE_inj) define p' where "p' = (∑g∈G'. q (dehomogenize x g) * g)" have "p' ∈ ideal G'" unfolding p'_def by (rule ideal.sum_in_spanI) also from ‹G' ⊆ G› have "… ⊆ ideal G" by (rule ideal.span_mono) finally have "p' ∈ ideal G" . with assms(5) have "homogenize x p' ∈ ideal G" (is "?p ∈ _") by (rule homogeneous_ideal_homogenize) assume "p ∈ punit.dgrad_p_set (varnum (X - {x})) 0" hence "p ∈ P[X - {x}]" by (simp only: dgrad_p_set_varnum) hence "indets p ⊆ X - {x}" by (rule PolysD) hence "x ∉ indets p" by blast have "p = dehomogenize x p" by (rule sym) (simp add: ‹x ∉ indets p›) also from inj have "… = dehomogenize x (∑g∈G'. q (dehomogenize x g) * dehomogenize x g)" by (simp add: p G0 sum.reindex) also have "… = dehomogenize x ?p" by (simp add: dehomogenize_sum dehomogenize_times p'_def) finally have p: "p = dehomogenize x ?p" . moreover assume "p ≠ 0" ultimately have "?p ≠ 0" by (auto simp del: dehomogenize_homogenize) with assms(4) ‹?p ∈ ideal G› obtain g where "g ∈ G" and "g ≠ 0" and adds: "lpp g adds lpp ?p" by (rule punit.GB_adds_lt[simplified]) from this(1) have "homogeneous g" by (rule assms(5)) show "∃g∈dehomogenize x ` G. g ≠ 0 ∧ lpp g adds lpp p" proof (intro bexI conjI notI) assume "dehomogenize x g = 0" hence "g = 0" using ‹homogeneous g› by (rule dehomogenize_zeroD) with ‹g ≠ 0› show False .. next from assms(1) ‹homogeneous g› have "lpp (dehomogenize x g) = except (lpp g) {x}" by (rule lp_dehomogenize) also from adds have "… adds except (lpp ?p) {x}" by (simp add: adds_poly_mapping le_fun_def lookup_except) also from assms(1) homogeneous_homogenize have "… = lpp (dehomogenize x ?p)" by (rule lp_dehomogenize[symmetric]) finally show "lpp (dehomogenize x g) adds lpp p" by (simp only: p) next from ‹g ∈ G› show "dehomogenize x g ∈ dehomogenize x ` G" by (rule imageI) qed qed end (* pm_powerprod *) context extended_ord_pm_powerprod begin lemma extended_ord_lp: assumes "None ∉ indets p" shows "restrict_indets_pp (extended_ord.lpp p) = lpp (restrict_indets p)" proof (cases "p = 0") case True thus ?thesis by simp next case False hence "extended_ord.lpp p ∈ keys p" by (rule extended_ord.punit.lt_in_keys) hence "restrict_indets_pp (extended_ord.lpp p) ∈ restrict_indets_pp ` keys p" by (rule imageI) also from assms have eq: "… = keys (restrict_indets p)" by (rule keys_restrict_indets[symmetric]) finally show ?thesis proof (rule punit.lt_eqI_keys[symmetric]) fix t assume "t ∈ keys (restrict_indets p)" then obtain s where "s ∈ keys p" and t: "t = restrict_indets_pp s" unfolding eq[symmetric] .. from this(1) have "extended_ord s (extended_ord.lpp p)" by (rule extended_ord.punit.lt_max_keys) thus "t ≼ restrict_indets_pp (extended_ord.lpp p)" by (auto simp: t extended_ord_def) qed qed lemma restrict_indets_reduced_GB: assumes "finite X" and "F ⊆ P[X]" shows "punit.is_Groebner_basis (restrict_indets ` extended_ord.punit.reduced_GB (homogenize None ` extend_indets ` F))" (is ?thesis1) and "ideal (restrict_indets ` extended_ord.punit.reduced_GB (homogenize None ` extend_indets ` F)) = ideal F" (is ?thesis2) and "restrict_indets ` extended_ord.punit.reduced_GB (homogenize None ` extend_indets ` F) ⊆ P[X]" (is ?thesis3) proof - let ?F = "homogenize None ` extend_indets ` F" let ?G = "extended_ord.punit.reduced_GB ?F" from assms(1) have "finite (insert None (Some ` X))" by simp moreover have "?F ⊆ P[insert None (Some ` X)]" proof fix hf assume "hf ∈ ?F" then obtain f where "f ∈ F" and hf: "hf = homogenize None (extend_indets f)" by auto from this(1) assms(2) have "f ∈ P[X]" .. hence "indets f ⊆ X" by (rule PolysD) hence "Some ` indets f ⊆ Some ` X" by (rule image_mono) with indets_extend_indets[of f] have "indets (extend_indets f) ⊆ Some ` X" by blast hence "insert None (indets (extend_indets f)) ⊆ insert None (Some ` X)" by blast with indets_homogenize_subset have "indets hf ⊆ insert None (Some ` X)" unfolding hf by (rule subset_trans) thus "hf ∈ P[insert None (Some ` X)]" by (rule PolysI_alt) qed ultimately have G_sub: "?G ⊆ P[insert None (Some ` X)]" and ideal_G: "ideal ?G = ideal ?F" and GB_G: "extended_ord.punit.is_reduced_GB ?G" by (rule extended_ord.reduced_GB_Polys, rule extended_ord.reduced_GB_ideal_Polys, rule extended_ord.reduced_GB_is_reduced_GB_Polys) show ?thesis3 proof fix g assume "g ∈ restrict_indets ` ?G" then obtain g' where "g' ∈ ?G" and g: "g = restrict_indets g'" .. from this(1) G_sub have "g' ∈ P[insert None (Some ` X)]" .. hence "indets g' ⊆ insert None (Some ` X)" by (rule PolysD) have "indets g ⊆ the ` (indets g' - {None})" by (simp only: g indets_restrict_indets_subset) also from ‹indets g' ⊆ insert None (Some ` X)› have "… ⊆ X" by auto finally show "g ∈ P[X]" by (rule PolysI_alt) qed from dickson_grading_varnum show ?thesis1 proof (rule punit.isGB_I_adds_lt[simplified]) from ‹?thesis3› show "restrict_indets ` ?G ⊆ punit.dgrad_p_set (varnum X) 0" by (simp only: dgrad_p_set_varnum) next fix p :: "('a ⇒⇩0 nat) ⇒⇩0 'b" assume "p ≠ 0" assume "p ∈ ideal (restrict_indets ` ?G)" hence "extend_indets p ∈ extend_indets ` ideal (restrict_indets ` ?G)" by (rule imageI) also have "… ⊆ ideal (extend_indets ` restrict_indets ` ?G)" by (fact extend_indets_ideal_subset) also have "… = ideal (dehomogenize None ` ?G)" by (simp only: image_comp extend_indets_comp_restrict_indets) finally have p_in_ideal: "extend_indets p ∈ ideal (dehomogenize None ` ?G)" . assume "p ∈ punit.dgrad_p_set (varnum X) 0" hence "p ∈ P[X]" by (simp only: dgrad_p_set_varnum) have "extended_ord.punit.is_Groebner_basis (dehomogenize None ` ?G)" using extended_ord_is_hom_ord ‹finite (insert None (Some ` X))› G_sub proof (rule extended_ord.isGB_dehomogenize) from GB_G show "extended_ord.punit.is_Groebner_basis ?G" by (rule extended_ord.punit.reduced_GB_D1) next fix g assume "g ∈ ?G" with _ GB_G ideal_G show "homogeneous g" proof (rule extended_ord.is_reduced_GB_homogeneous) fix hf assume "hf ∈ ?F" then obtain f where "hf = homogenize None f" .. thus "homogeneous hf" by (simp only: homogeneous_homogenize) qed qed moreover note p_in_ideal moreover from ‹p ≠ 0› have "extend_indets p ≠ 0" by simp ultimately obtain g where g_in: "g ∈ dehomogenize None ` ?G" and "g ≠ 0" and adds: "extended_ord.lpp g adds extended_ord.lpp (extend_indets p)" by (rule extended_ord.punit.GB_adds_lt[simplified]) have "None ∉ indets g" proof assume "None ∈ indets g" moreover from g_in obtain g0 where "g = dehomogenize None g0" .. ultimately show False using indets_dehomogenize[of None g0] by blast qed show "∃g∈restrict_indets ` ?G. g ≠ 0 ∧ lpp g adds lpp p" proof (intro bexI conjI notI) have "lpp (restrict_indets g) = restrict_indets_pp (extended_ord.lpp g)" by (rule sym, intro extended_ord_lp ‹None ∉ indets g›) also from adds have "… adds restrict_indets_pp (extended_ord.lpp (extend_indets p))" by (simp add: adds_poly_mapping le_fun_def lookup_restrict_indets_pp) also have "… = lpp (restrict_indets (extend_indets p))" proof (intro extended_ord_lp notI) assume "None ∈ indets (extend_indets p)" thus False by (simp add: indets_extend_indets) qed also have "… = lpp p" by simp finally show "lpp (restrict_indets g) adds lpp p" . next from g_in have "restrict_indets g ∈ restrict_indets ` dehomogenize None ` ?G" by (rule imageI) also have "… = restrict_indets ` ?G" by (simp only: image_comp restrict_indets_comp_dehomogenize) finally show "restrict_indets g ∈ restrict_indets ` ?G" . next assume "restrict_indets g = 0" with ‹None ∉ indets g› extend_restrict_indets have "g = 0" by fastforce with ‹g ≠ 0› show False .. qed qed (fact assms(1)) from ideal_G show ?thesis2 by (rule ideal_restrict_indets) qed end end (* theory *)